From 80bad6c710fc581760d9b172a641071cd9180ca6 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 21 Jun 2023 09:50:02 -0400 Subject: [PATCH 001/170] incomplete first pass at basic SQL parsing and conversion to relational expression --- project-m36.cabal | 12 +- src/bin/SQL/Interpreter/Base.hs | 91 +++++++++ src/bin/SQL/Interpreter/Convert.hs | 82 ++++++++ src/bin/SQL/Interpreter/Select.hs | 291 +++++++++++++++++++++++++++++ test/SQL/InterpreterTest.hs | 33 ++++ 5 files changed, 508 insertions(+), 1 deletion(-) create mode 100644 src/bin/SQL/Interpreter/Base.hs create mode 100644 src/bin/SQL/Interpreter/Convert.hs create mode 100644 src/bin/SQL/Interpreter/Select.hs create mode 100644 test/SQL/InterpreterTest.hs diff --git a/project-m36.cabal b/project-m36.cabal index d5ba23a2..707e9b51 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -214,7 +214,10 @@ Executable tutd TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, - TutorialD.Printer + TutorialD.Printer, + SQL.Interpreter.Base, + SQL.Interpreter.Select, + SQL.Interpreter.Convert main-is: TutorialD/tutd.hs CC-Options: -fPIC if os(windows) @@ -311,6 +314,13 @@ Benchmark update-exprs if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall -fexternal-interpreter +Test-Suite test-sql + import: commontest + type: exitcode-stdio-1.0 + main-is: SQL/InterpreterTest.hs + Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, SQL.Interpreter.Convert + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific + Test-Suite test-tutoriald import: commontest type: exitcode-stdio-1.0 diff --git a/src/bin/SQL/Interpreter/Base.hs b/src/bin/SQL/Interpreter/Base.hs new file mode 100644 index 00000000..a42ab360 --- /dev/null +++ b/src/bin/SQL/Interpreter/Base.hs @@ -0,0 +1,91 @@ +module SQL.Interpreter.Base where +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as Lex +import Data.Void (Void) +import Data.Text as T (Text, singleton, pack, splitOn) + + +type Parser = Parsec Void Text + +-- consumes only horizontal spaces +spaceConsumer :: Parser () +spaceConsumer = Lex.space space1 (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}") + +opChar :: Parser Char +opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces + +-- parse case-insensitive keyword +reserved :: Text -> Parser () +reserved word = do + try (string' word *> spaceConsumer) + +reserveds :: Text -> Parser () +reserveds words' = do + let words'' = T.splitOn " " words' + sequence_ (map reserved words'') + +-- does not consume trailing spaces +qualifiedNameSegment :: Text -> Parser Text +qualifiedNameSegment sym = string' sym + +reservedOp :: Text -> Parser () +reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer) + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +braces :: Parser a -> Parser a +braces = between (symbol "{") (symbol "}") + +identifier :: Parser Text +identifier = do + istart <- letterChar <|> char '_' + identifierRemainder istart + +identifierRemainder :: Char -> Parser Text +identifierRemainder c = do + rest <- many (alphaNumChar <|> char '_' <|> char '#') + spaceConsumer + pure (pack (c:rest)) + +symbol :: Text -> Parser Text +symbol sym = Lex.symbol spaceConsumer sym + +comma :: Parser Text +comma = symbol "," + +sepByComma1 :: Parser a -> Parser [a] +sepByComma1 p = sepBy1 p comma + +sepByComma :: Parser a -> Parser [a] +sepByComma p = sepBy p comma + +pipe :: Parser Text +pipe = symbol "|" + +semi :: Parser Text +semi = symbol ";" + +nline :: Parser Text +nline = (T.singleton <$> newline) <|> crlf + +integer :: Parser Integer +integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer + +natural :: Parser Integer +natural = Lex.decimal <* spaceConsumer + +float :: Parser Double +float = Lex.float <* spaceConsumer + +-- | When an identifier is quoted, it can contain any string. +quotedIdentifier :: Parser Text +quotedIdentifier = + T.pack <$> (doubleQuote *> many (escapedDoubleQuote <|> notDoubleQuote) <* doubleQuote) + where + doubleQuote = char '"' + escapedDoubleQuote = char '"' >> char '"' + notDoubleQuote = satisfy ('"' /=) + + diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs new file mode 100644 index 00000000..c4134364 --- /dev/null +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -0,0 +1,82 @@ +--convert SQL into relational or database context expressions +{-# LANGUAGE TypeFamilies, FlexibleInstances #-} +module SQL.Interpreter.Convert where +import ProjectM36.Base +import SQL.Interpreter.Select +import Data.Kind (Type) +import Data.List (foldl') +import Data.Text as T (pack) +import ProjectM36.Relation +import Control.Monad (foldM) + +data ConvertError = NotSupportedError + +class SQLConvert sqlexpr where + type ConverterF sqlexpr :: Type + convert :: sqlexpr -> Either ConvertError (ConverterF sqlexpr) + +instance SQLConvert Select where + type ConverterF Select = RelationalExpr + convert sel = do + (extendExprs, attrNames) <- convert (projectionClause sel) + let projectionAttrExprs = foldl' UnionAttributeNames (AttributeNames mempty) attrNames + relExpr <- case tableExpr sel of + Nothing -> pure $ ExistingRelation relationTrue + Just tExpr -> convert tExpr + -- add projection, if necessary + let projection = + if null attrNames then + relExpr + else + Project projectionAttrExprs relExpr + extendedExpr = foldl' (\acc extExpr -> + Extend extExpr acc) projection extendExprs + pure extendedExpr + +instance SQLConvert [SelectItem] where + type ConverterF [SelectItem] = ([ExtendTupleExpr],[AttributeNames]) + convert selItems = + --SQL projections conflate static values to appear in a table with attribute names to include in the resultant relation + pure $ foldl' (\(extendExprs', projectionAttrExprs') (c,selItem) -> + let ext :: Atom -> Maybe AliasName -> ([ExtendTupleExpr], [AttributeNames]) + ext atom mAlias = (extendExprs' <> [AttributeExtendTupleExpr (attrName' mAlias) (NakedAtomExpr atom)], projectionAttrExprs') + --proj attr mAlias = (extendExprs', projectionAttrExprs' <> []) + attrName' (Just (AliasName nam)) = nam + attrName' Nothing = "attr_" <> T.pack (show c) + in + case selItem of + (IntegerLiteral i, mAlias) -> ext (IntegerAtom i) mAlias + (Identifier (QualifiedName [Asterisk]), Nothing) -> (extendExprs', projectionAttrExprs') + ) mempty + (zip [1::Int ..] selItems) + +instance SQLConvert TableExpr where + type ConverterF TableExpr = RelationalExpr + --does not handle non-relational aspects such as offset, order by, or limit + convert tExpr = do + fromExpr <- convert (fromClause tExpr) + case whereClause tExpr of + Just whereExpr -> do + restrictPredExpr <- convert whereExpr + pure $ Restrict restrictPredExpr fromExpr + Nothing -> pure fromExpr + --group by + --having + + +instance SQLConvert [TableRef] where + type ConverterF [TableRef] = RelationalExpr + convert (firstRef:trefs) = do + firstRel <- convert firstRef + foldM joinTRef firstRel trefs + where + joinTRef = undefined + +instance SQLConvert TableRef where + type ConverterF TableRef = RelationalExpr + convert (SimpleTableRef (QualifiedName [Name nam])) = + pure $ RelationVariable nam () + +instance SQLConvert RestrictionExpr where + type ConverterF RestrictionExpr = RestrictionPredicateExpr + convert = undefined diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs new file mode 100644 index 00000000..a36e05cc --- /dev/null +++ b/src/bin/SQL/Interpreter/Select.hs @@ -0,0 +1,291 @@ +module SQL.Interpreter.Select where +import Text.Megaparsec +import Text.Megaparsec.Char +import Control.Monad.Combinators.Expr as E +import SQL.Interpreter.Base +import Data.Text (Text, splitOn) +import Data.Functor + +-- we use an intermediate data structure because it may need to be probed into order to create a proper relational expression +data Select = Select { distinctness :: Maybe Distinctness, + projectionClause :: [SelectItem], + tableExpr :: Maybe TableExpr + } + deriving (Show, Eq) + +data InFlag = In | NotIn + deriving (Show, Eq) + +data ComparisonOperator = OpLT | OpGT | OpGTE | OpEQ | OpNE | OpLTE + deriving (Show, Eq) + +data QuantifiedComparisonPredicate = QCAny | QCSome | QCAll + deriving (Show,Eq) + +data TableRef = SimpleTableRef QualifiedName + | JoinTableRef JoinType TableRef (Maybe JoinCondition) + | AliasedTableRef TableRef AliasName + + | QueryTableRef Select + deriving (Show, Eq) + +data ScalarExpr = IntegerLiteral Integer + | DoubleLiteral Double + -- | Interval + | Identifier QualifiedName + | BinaryOperator ScalarExpr QualifiedName ScalarExpr + | PrefixOperator QualifiedName ScalarExpr + | PostfixOperator ScalarExpr QualifiedName + | BetweenOperator ScalarExpr ScalarExpr ScalarExpr + | FunctionApplication QualifiedName ScalarExpr + | CaseExpr { caseWhens :: [([ScalarExpr],ScalarExpr)], + caseElse :: Maybe ScalarExpr } + | QuantifiedComparison { qcExpr :: ScalarExpr, + qcOperator :: ComparisonOperator, + qcPredicate :: QuantifiedComparisonPredicate, + qcQuery :: Select } + + | InExpr InFlag ScalarExpr InPredicateValue + -- | ExistsSubQuery Select + -- | UniqueSubQuery Select + -- | ScalarSubQuery Select + deriving (Show, Eq) + +data InPredicateValue = InList [ScalarExpr] | InQueryExpr Select | InScalarExpr ScalarExpr + deriving (Eq, Show) + +data GroupByExpr = Group ScalarExpr + deriving (Show, Eq) + +data HavingExpr = Having ScalarExpr + deriving (Show, Eq) + +data SortExpr = SortExpr ScalarExpr (Maybe Direction) (Maybe NullsOrder) + deriving (Show, Eq) + +data Direction = Ascending | Descending + deriving (Show, Eq) + +data NullsOrder = NullsFirst | NullsLast + deriving (Show, Eq) + +data JoinType = InnerJoin | RightOuterJoin | LeftOuterJoin | FullOuterJoin | CrossJoin | NaturalJoin + deriving (Show, Eq) + +data JoinCondition = JoinOn ScalarExpr | JoinUsing [QualifiedName] + deriving (Show, Eq) + +data Alias = Alias QualifiedName (Maybe AliasName) + deriving (Show, Eq) + +data QualifiedName = QualifiedName [Name] --dot-delimited reference + deriving (Show, Eq) + +data Name = Name Text | Asterisk + deriving (Show, Eq) + +newtype AliasName = AliasName Text + deriving (Show, Eq) + +data Distinctness = Distinct | All deriving (Show, Eq) + +selectP :: Parser Select +selectP = do + reserved "select" +-- distinctOptions + projection <- selectItemListP + tExpr <- optional tableExprP + pure (Select { distinctness = Nothing, + projectionClause = projection, + tableExpr = tExpr + }) + +type SelectItem = (ScalarExpr, Maybe AliasName) + +selectItemListP :: Parser [SelectItem] +selectItemListP = sepBy1 selectItemP comma + +selectItemP :: Parser SelectItem +selectItemP = (,) <$> scalarExprP <*> optional (reserved "as" *> aliasNameP) + +newtype RestrictionExpr = RestrictionExpr ScalarExpr + deriving (Show, Eq) + +data TableExpr = + TableExpr { fromClause :: [TableRef], + whereClause :: Maybe RestrictionExpr, + groupByClause :: [GroupByExpr], + havingClause :: Maybe HavingExpr, + orderByClause :: [SortExpr], + limitClause :: Maybe Integer, + offsetClause :: Maybe Integer + } + deriving (Show, Eq) + +tableExprP :: Parser TableExpr +tableExprP = + TableExpr <$> fromP <*> optional whereP <*> option [] groupByP <*> optional havingP <*> option [] orderByP <*> limitP <*> offsetP + +fromP :: Parser [TableRef] +fromP = reserved "from" *> ((:) <$> nonJoinTref <*> sepByComma joinP) + where + nonJoinTref = choice [parens $ QueryTableRef <$> selectP, + try (AliasedTableRef <$> simpleRef <*> (reserved "as" *> aliasNameP)), + simpleRef] + simpleRef = SimpleTableRef <$> qualifiedNameP + joinP = JoinTableRef <$> joinTypeP <*> nonJoinTref <*> optional joinConditionP + +joinConditionP :: Parser JoinCondition +joinConditionP = do + (JoinOn <$> (reserved "on" *> scalarExprP)) <|> + JoinUsing <$> (reserved "using" *> parens (sepBy1 qualifiedNameP comma)) + +joinTypeP :: Parser JoinType +joinTypeP = choice [reserveds "cross join" $> CrossJoin, + reserveds "inner join" $> InnerJoin, + (reserveds "left outer join" <|> + reserveds "left join") $> LeftOuterJoin, + (reserveds "right outer join" <|> + reserveds "right join") $> RightOuterJoin, + (reserveds "full join" <|> + reserveds "full outer join") $> FullOuterJoin, + (reserved "inner join" <|> reserveds "join") $> InnerJoin, + reserved "natural join" $> NaturalJoin] + + +whereP :: Parser RestrictionExpr +whereP = reserved "where" *> (RestrictionExpr <$> scalarExprP) + +groupByP :: Parser [GroupByExpr] +groupByP = + reserveds "group by" *> sepBy1 (Group <$> scalarExprP) comma + +havingP :: Parser HavingExpr +havingP = reserved "having" *> (Having <$> scalarExprP) + +orderByP :: Parser [SortExpr] +orderByP = + reserveds "order by" *> (sepByComma1 (SortExpr <$> scalarExprP <*> optional directionP <*> optional nullsOrderP)) + where + directionP = (reserved "asc" $> Ascending) <|> + (reserved "desc" $> Descending) + nullsOrderP = (reserveds "nulls first" $> NullsFirst) <|> + (reserveds "nulls last" $> NullsLast) + +nameP :: Parser Text +nameP = quotedIdentifier <|> identifier + +aliasNameP :: Parser AliasName +aliasNameP = AliasName <$> (quotedIdentifier <|> identifier) + +qualifiedNameP :: Parser QualifiedName +qualifiedNameP = QualifiedName <$> sepBy1 (Name <$> nameP) (char '.') + +scalarExprP :: Parser ScalarExpr +scalarExprP = E.makeExprParser scalarTermP scalarExprOp + +scalarExprOp :: [[E.Operator Parser ScalarExpr]] +scalarExprOp = + [[qComparisonOp], + [prefixSymbol "+", + prefixSymbol "-"], + [binarySymbolL "^"], + map binarySymbolL ["\"","*","%"], + map binarySymbolL ["+","-"], + [binarySymbolR "||", + prefixSymbol "~", + binarySymbolR "&", + binarySymbolR "|"], + [binarySymbolN "like", + E.Postfix $ try inSuffixP, + E.Postfix betweenSuffixP + --binarySymbolsN ["not", "like"] + ], + map binarySymbolN ["<",">",">=","<=","!=","<>","="], +{- [binarySymbolsN ["is", "distinct", "from"], + binarySymbolsN ["is", "not", "distinct", "from"]],-} + [prefixSymbol "not"], + [binarySymbolL "or"] + -- AT TIME ZONE + ] + where + prefixSymbol s = E.Prefix $ PrefixOperator <$> qualifiedOperatorP s + binarySymbolL s = E.InfixL $ binary s + binary s = do + op <- qualifiedOperatorP s + pure (\a b -> BinaryOperator a op b) + binarySymbolR s = E.InfixR $ binary s + binarySymbolN s = E.InfixN $ binary s + qComparisonOp = E.Postfix $ try quantifiedComparisonSuffixP + +qualifiedOperatorP :: Text -> Parser QualifiedName +qualifiedOperatorP sym = QualifiedName <$> sequence (map (\s -> (Name <$> qualifiedNameSegment s) <* char '.') (splitOn "." sym)) + +betweenSuffixP :: Parser (ScalarExpr -> ScalarExpr) +betweenSuffixP = do + reserved "between" + arg1 <- scalarExprP + reserved "and" + arg2 <- scalarExprP + pure (\a -> BetweenOperator a arg1 arg2) + +inSuffixP :: Parser (ScalarExpr -> ScalarExpr) +inSuffixP = do + matchIn <|> matchNotIn + where + matchIn = do + reserved "in" + pred' <- inPredicateValue + pure (\sexpr -> InExpr In sexpr pred') + matchNotIn = do + reserved "not" >> reserved "in" + pred' <- inPredicateValue + pure (\sexpr -> InExpr NotIn sexpr pred') + inPredicateValue = parens ((InQueryExpr <$> selectP) <|> + (InList <$> sepBy1 scalarExprP comma)) <|> + InScalarExpr <$> scalarExprP + + +quantifiedComparisonSuffixP :: Parser (ScalarExpr -> ScalarExpr) +quantifiedComparisonSuffixP = do + op <- comparisonOperatorP + quantOp <- (reserved "any" $> QCAny) <|> + (reserved "some" $> QCSome) <|> + (reserved "all" $> QCAll) + subq <- parens selectP + pure (\sexpr -> QuantifiedComparison { qcExpr = sexpr, + qcOperator = op, + qcPredicate = quantOp, + qcQuery = subq }) + +comparisonOperatorP :: Parser ComparisonOperator +comparisonOperatorP = choice (map (\(match', op) -> reserved match' $> op) ops) + where ops =[(">", OpGT), + ("<", OpLT), + ("=", OpEQ), + (">=", OpGTE), + ("<=", OpLTE), + ("<>", OpNE), + ("!=", OpNE)] + +scalarTermP :: Parser ScalarExpr +scalarTermP = choice [ + --,subQueryExpr +-- caseExpr, + --,cast +-- subquery, +-- pseudoArgFunc, -- includes NOW, NOW(), CURRENT_USER, TRIM(...), etc. + Identifier <$> qualifiedNameInProjectionP] + "scalar expression" + +-- | col, table.col, table.*, * +qualifiedNameInProjectionP :: Parser QualifiedName +qualifiedNameInProjectionP = + QualifiedName <$> sepBy1 ((Name <$> nameP) <|> (char '*' $> Asterisk)) (char '.') <* spaceConsumer + +limitP :: Parser (Maybe Integer) +limitP = optional (reserved "limit" *> integer) + +offsetP :: Parser (Maybe Integer) +offsetP = optional (reserved "offset" *> integer) + diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs new file mode 100644 index 00000000..d98b6bb4 --- /dev/null +++ b/test/SQL/InterpreterTest.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +import SQL.Interpreter.Select +import SQL.Interpreter.Convert +import TutorialD.Interpreter.RelationalExpr +import System.Exit +import Test.HUnit +import Text.Megaparsec +import qualified Data.Text as T + +main :: IO () +main = do + tcounts <- runTestTT (TestList tests) + if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess + where + tests = [testSelect] + +testSelect :: Test +testSelect = TestCase $ do + -- check that SQL and tutd compile to same thing + let p tin = parse selectP "test" tin + readTests = [("SELECT * FROM test", "test")] + check (sql, tutd) = do + --parse SQL + let Right select = parse selectP "test" sql + --parse tutd + Right relExpr = parse relExprP "test" tutd + Right selectAsRelExpr = convert select + print selectAsRelExpr + assertEqual (T.unpack sql) selectAsRelExpr relExpr + mapM_ check readTests + + assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName [Name "test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") + From 4fd8ace86e718d202d12b90e2fe42c2dfd26c3f2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 24 Jun 2023 21:40:53 -0400 Subject: [PATCH 002/170] wip checkpoint with basic scalarexpr --- src/bin/SQL/Interpreter/Base.hs | 4 +- src/bin/SQL/Interpreter/Convert.hs | 104 ++++++++++++++++++--------- src/bin/SQL/Interpreter/Select.hs | 112 +++++++++++++++++++++-------- test/SQL/InterpreterTest.hs | 19 +++-- 4 files changed, 168 insertions(+), 71 deletions(-) diff --git a/src/bin/SQL/Interpreter/Base.hs b/src/bin/SQL/Interpreter/Base.hs index a42ab360..06fb276d 100644 --- a/src/bin/SQL/Interpreter/Base.hs +++ b/src/bin/SQL/Interpreter/Base.hs @@ -76,8 +76,8 @@ integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer natural :: Parser Integer natural = Lex.decimal <* spaceConsumer -float :: Parser Double -float = Lex.float <* spaceConsumer +double :: Parser Double +double = Lex.float <* spaceConsumer -- | When an identifier is quoted, it can contain any string. quotedIdentifier :: Parser Text diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index c4134364..0fa97d43 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -1,54 +1,51 @@ --convert SQL into relational or database context expressions -{-# LANGUAGE TypeFamilies, FlexibleInstances #-} +{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables #-} module SQL.Interpreter.Convert where import ProjectM36.Base import SQL.Interpreter.Select import Data.Kind (Type) -import Data.List (foldl') -import Data.Text as T (pack) +import Data.Text as T (pack,intercalate,Text) import ProjectM36.Relation import Control.Monad (foldM) +import qualified Data.Set as S -data ConvertError = NotSupportedError +data SQLError = NotSupportedError T.Text | + TypeMismatch AtomType AtomType | + NoSuchFunction QualifiedName + deriving (Show, Eq) class SQLConvert sqlexpr where type ConverterF sqlexpr :: Type - convert :: sqlexpr -> Either ConvertError (ConverterF sqlexpr) + convert :: sqlexpr -> Either SQLError (ConverterF sqlexpr) instance SQLConvert Select where type ConverterF Select = RelationalExpr convert sel = do - (extendExprs, attrNames) <- convert (projectionClause sel) - let projectionAttrExprs = foldl' UnionAttributeNames (AttributeNames mempty) attrNames - relExpr <- case tableExpr sel of + projF <- convert (projectionClause sel) + case tableExpr sel of Nothing -> pure $ ExistingRelation relationTrue - Just tExpr -> convert tExpr - -- add projection, if necessary - let projection = - if null attrNames then - relExpr - else - Project projectionAttrExprs relExpr - extendedExpr = foldl' (\acc extExpr -> - Extend extExpr acc) projection extendExprs - pure extendedExpr + Just tExpr -> projF <$> convert tExpr instance SQLConvert [SelectItem] where - type ConverterF [SelectItem] = ([ExtendTupleExpr],[AttributeNames]) - convert selItems = - --SQL projections conflate static values to appear in a table with attribute names to include in the resultant relation - pure $ foldl' (\(extendExprs', projectionAttrExprs') (c,selItem) -> - let ext :: Atom -> Maybe AliasName -> ([ExtendTupleExpr], [AttributeNames]) - ext atom mAlias = (extendExprs' <> [AttributeExtendTupleExpr (attrName' mAlias) (NakedAtomExpr atom)], projectionAttrExprs') - --proj attr mAlias = (extendExprs', projectionAttrExprs' <> []) - attrName' (Just (AliasName nam)) = nam - attrName' Nothing = "attr_" <> T.pack (show c) - in - case selItem of - (IntegerLiteral i, mAlias) -> ext (IntegerAtom i) mAlias - (Identifier (QualifiedName [Asterisk]), Nothing) -> (extendExprs', projectionAttrExprs') - ) mempty - (zip [1::Int ..] selItems) + type ConverterF [SelectItem] = (RelationalExpr -> RelationalExpr) + convert selItems = do + --SQL projections conflate static values to appear in a table with attribute names to include in the resultant relation + let folder :: (RelationalExpr -> RelationalExpr) -> (Int, SelectItem) -> Either SQLError (RelationalExpr -> RelationalExpr) + folder _ (c,selItem) = do + let ext atom mAlias = pure $ Extend (AttributeExtendTupleExpr (attrName' mAlias) (NakedAtomExpr atom)) + --simple projection, no alias + proj :: AttributeName -> Maybe AliasName -> (RelationalExpr -> RelationalExpr) + proj attr Nothing f = Project (AttributeNames (S.singleton attr)) f + proj attr alias f = Rename attr (attrName' alias) (proj attr Nothing f) + attrName' (Just (AliasName nam)) = nam + attrName' Nothing = "attr_" <> T.pack (show c) + case selItem of + (IntegerLiteral i, mAlias) -> ext (IntegerAtom i) mAlias + -- select * - does nothing + (Identifier (QualifiedProjectionName [Asterisk]), Nothing) -> pure id + -- select a, simple, unqualified attribute projection + (Identifier (QualifiedProjectionName [ProjectionName nam]), Nothing) -> pure $ proj nam Nothing + foldM folder id (zip [1::Int ..] selItems) instance SQLConvert TableExpr where type ConverterF TableExpr = RelationalExpr @@ -66,6 +63,7 @@ instance SQLConvert TableExpr where instance SQLConvert [TableRef] where type ConverterF [TableRef] = RelationalExpr + convert [] = pure (ExistingRelation relationFalse) convert (firstRef:trefs) = do firstRel <- convert firstRef foldM joinTRef firstRel trefs @@ -74,9 +72,45 @@ instance SQLConvert [TableRef] where instance SQLConvert TableRef where type ConverterF TableRef = RelationalExpr - convert (SimpleTableRef (QualifiedName [Name nam])) = + convert (SimpleTableRef (QualifiedName [nam])) = pure $ RelationVariable nam () instance SQLConvert RestrictionExpr where type ConverterF RestrictionExpr = RestrictionPredicateExpr - convert = undefined + convert (RestrictionExpr rexpr) = do + let wrongType t = Left $ TypeMismatch t BoolAtomType --must be boolean expression + attrName' (QualifiedName ts) = T.intercalate "." ts + case rexpr of + IntegerLiteral{} -> wrongType IntegerAtomType + DoubleLiteral{} -> wrongType DoubleAtomType + StringLiteral{} -> wrongType TextAtomType + Identifier i -> wrongType TextAtomType -- could be a better error here + BinaryOperator (Identifier a) (QualifiedName ["="]) exprMatch -> --we don't know here if this results in a boolean expression, so we pass it down + AttributeEqualityPredicate (attrName' a) <$> convert exprMatch + +instance SQLConvert ScalarExpr where + type ConverterF ScalarExpr = AtomExpr + convert expr = do + let naked = pure . NakedAtomExpr + attrName' (QualifiedName ts) = T.intercalate "." ts + sqlFuncs = [(">","gt"), + ("<","lt"), + (">=","gte"), + ("<=","lte"), + ("=","eq"), + ("!=","not_eq"), -- function missing + ("<>", "not_eq") -- function missing + ] + case expr of + IntegerLiteral i -> naked (IntegerAtom i) + DoubleLiteral d -> naked (DoubleAtom d) + StringLiteral s -> naked (TextAtom s) + Identifier i -> pure $ AttributeAtomExpr (attrName' i) + BinaryOperator exprA qn@(QualifiedName [op]) exprB -> do + a <- convert exprA + b <- convert exprB + func <- case lookup op sqlFuncs of + Nothing -> Left $ NoSuchFunction qn + Just f -> pure f + pure $ FunctionAtomExpr func [a,b] () + diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index a36e05cc..a09682b3 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -4,6 +4,7 @@ import Text.Megaparsec.Char import Control.Monad.Combinators.Expr as E import SQL.Interpreter.Base import Data.Text (Text, splitOn) +import qualified Data.Text as T import Data.Functor -- we use an intermediate data structure because it may need to be probed into order to create a proper relational expression @@ -29,23 +30,28 @@ data TableRef = SimpleTableRef QualifiedName | QueryTableRef Select deriving (Show, Eq) -data ScalarExpr = IntegerLiteral Integer +-- distinguish between projection attributes which may include an asterisk and scalar expressions (such as in a where clause) where an asterisk is invalid +type ProjectionScalarExpr = ScalarExprBase QualifiedProjectionName +type ScalarExpr = ScalarExprBase QualifiedName + +data ScalarExprBase n = IntegerLiteral Integer | DoubleLiteral Double + | StringLiteral Text -- | Interval - | Identifier QualifiedName - | BinaryOperator ScalarExpr QualifiedName ScalarExpr - | PrefixOperator QualifiedName ScalarExpr - | PostfixOperator ScalarExpr QualifiedName - | BetweenOperator ScalarExpr ScalarExpr ScalarExpr - | FunctionApplication QualifiedName ScalarExpr - | CaseExpr { caseWhens :: [([ScalarExpr],ScalarExpr)], - caseElse :: Maybe ScalarExpr } - | QuantifiedComparison { qcExpr :: ScalarExpr, + | Identifier n + | BinaryOperator (ScalarExprBase n) QualifiedName (ScalarExprBase n) + | PrefixOperator QualifiedName (ScalarExprBase n) + | PostfixOperator (ScalarExprBase n) QualifiedName + | BetweenOperator (ScalarExprBase n) (ScalarExprBase n) (ScalarExprBase n) + | FunctionApplication QualifiedName (ScalarExprBase n) + | CaseExpr { caseWhens :: [([ScalarExprBase n],ScalarExprBase n)], + caseElse :: Maybe (ScalarExprBase n) } + | QuantifiedComparison { qcExpr :: (ScalarExprBase n), qcOperator :: ComparisonOperator, qcPredicate :: QuantifiedComparisonPredicate, qcQuery :: Select } - | InExpr InFlag ScalarExpr InPredicateValue + | InExpr InFlag (ScalarExprBase n) InPredicateValue -- | ExistsSubQuery Select -- | UniqueSubQuery Select -- | ScalarSubQuery Select @@ -78,10 +84,13 @@ data JoinCondition = JoinOn ScalarExpr | JoinUsing [QualifiedName] data Alias = Alias QualifiedName (Maybe AliasName) deriving (Show, Eq) -data QualifiedName = QualifiedName [Name] --dot-delimited reference +data QualifiedProjectionName = QualifiedProjectionName [ProjectionName] --dot-delimited reference + deriving (Show, Eq) + +data ProjectionName = ProjectionName Text | Asterisk deriving (Show, Eq) -data Name = Name Text | Asterisk +data QualifiedName = QualifiedName [Text] deriving (Show, Eq) newtype AliasName = AliasName Text @@ -100,7 +109,7 @@ selectP = do tableExpr = tExpr }) -type SelectItem = (ScalarExpr, Maybe AliasName) +type SelectItem = (ProjectionScalarExpr, Maybe AliasName) selectItemListP :: Parser [SelectItem] selectItemListP = sepBy1 selectItemP comma @@ -178,13 +187,13 @@ nameP = quotedIdentifier <|> identifier aliasNameP :: Parser AliasName aliasNameP = AliasName <$> (quotedIdentifier <|> identifier) -qualifiedNameP :: Parser QualifiedName -qualifiedNameP = QualifiedName <$> sepBy1 (Name <$> nameP) (char '.') +--qualifiedNameP :: Parser QualifiedName +--qualifiedNameP = -scalarExprP :: Parser ScalarExpr +scalarExprP :: QualifiedNameP a => Parser (ScalarExprBase a) scalarExprP = E.makeExprParser scalarTermP scalarExprOp -scalarExprOp :: [[E.Operator Parser ScalarExpr]] +scalarExprOp :: QualifiedNameP a => [[E.Operator Parser (ScalarExprBase a)]] scalarExprOp = [[qComparisonOp], [prefixSymbol "+", @@ -219,17 +228,31 @@ scalarExprOp = qComparisonOp = E.Postfix $ try quantifiedComparisonSuffixP qualifiedOperatorP :: Text -> Parser QualifiedName -qualifiedOperatorP sym = QualifiedName <$> sequence (map (\s -> (Name <$> qualifiedNameSegment s) <* char '.') (splitOn "." sym)) - -betweenSuffixP :: Parser (ScalarExpr -> ScalarExpr) +qualifiedOperatorP sym = + QualifiedName <$> segmentsP (splitOn "." sym) + where + segmentsP :: [Text] -> Parser [Text] + segmentsP segments = case segments of + [] -> error "empty operator" + [seg] -> do + final <- qualifiedNameSegment seg + pure [final] + (seg:remainder) -> do + first <- qualifiedNameSegment seg + _ <- char '.' + rem' <- segmentsP remainder + pure (first:rem') + + +betweenSuffixP :: QualifiedNameP a => Parser (ScalarExprBase a -> ScalarExprBase a) betweenSuffixP = do reserved "between" arg1 <- scalarExprP reserved "and" arg2 <- scalarExprP - pure (\a -> BetweenOperator a arg1 arg2) + pure (\x -> BetweenOperator x arg1 arg2) -inSuffixP :: Parser (ScalarExpr -> ScalarExpr) +inSuffixP :: QualifiedNameP a => Parser (ScalarExprBase a -> ScalarExprBase a) inSuffixP = do matchIn <|> matchNotIn where @@ -246,7 +269,7 @@ inSuffixP = do InScalarExpr <$> scalarExprP -quantifiedComparisonSuffixP :: Parser (ScalarExpr -> ScalarExpr) +quantifiedComparisonSuffixP :: QualifiedNameP a => Parser (ScalarExprBase a -> ScalarExprBase a) quantifiedComparisonSuffixP = do op <- comparisonOperatorP quantOp <- (reserved "any" $> QCAny) <|> @@ -268,20 +291,51 @@ comparisonOperatorP = choice (map (\(match', op) -> reserved match' $> op) ops) ("<>", OpNE), ("!=", OpNE)] -scalarTermP :: Parser ScalarExpr +simpleLiteralP :: Parser (ScalarExprBase a) +simpleLiteralP = try doubleLiteralP <|> integerLiteralP <|> stringLiteralP + +doubleLiteralP :: Parser (ScalarExprBase a) +doubleLiteralP = DoubleLiteral <$> double + +integerLiteralP :: Parser (ScalarExprBase a) +integerLiteralP = IntegerLiteral <$> integer + +stringLiteralP :: Parser (ScalarExprBase a) +stringLiteralP = StringLiteral <$> stringP + where + stringP = do + void $ char '\'' + stringEndP + stringEndP = do + capture <- T.pack <$> manyTill printChar (char '\'') + choice [char '\'' *> (do + rest <- stringEndP + pure $ T.concat [capture, "'",rest]), --quoted quote + pure capture + ] + +scalarTermP :: QualifiedNameP a => Parser (ScalarExprBase a) scalarTermP = choice [ + simpleLiteralP, --,subQueryExpr -- caseExpr, --,cast -- subquery, -- pseudoArgFunc, -- includes NOW, NOW(), CURRENT_USER, TRIM(...), etc. - Identifier <$> qualifiedNameInProjectionP] + Identifier <$> qualifiedNameP] "scalar expression" +-- used to distinguish between sections which may include an asterisk and those which cannot +class QualifiedNameP a where + qualifiedNameP :: Parser a + -- | col, table.col, table.*, * -qualifiedNameInProjectionP :: Parser QualifiedName -qualifiedNameInProjectionP = - QualifiedName <$> sepBy1 ((Name <$> nameP) <|> (char '*' $> Asterisk)) (char '.') <* spaceConsumer +instance QualifiedNameP QualifiedProjectionName where + qualifiedNameP = + QualifiedProjectionName <$> sepBy1 ((ProjectionName <$> nameP) <|> (char '*' $> Asterisk)) (char '.') <* spaceConsumer + +instance QualifiedNameP QualifiedName where + qualifiedNameP = QualifiedName <$> sepBy1 nameP (char '.') limitP :: Parser (Maybe Integer) limitP = optional (reserved "limit" *> integer) diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index d98b6bb4..81726512 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -18,16 +18,25 @@ testSelect :: Test testSelect = TestCase $ do -- check that SQL and tutd compile to same thing let p tin = parse selectP "test" tin - readTests = [("SELECT * FROM test", "test")] + readTests = [("SELECT * FROM test", "test"), + ("SELECT a FROM test", "test{a}"), + ("SELECT a FROM test where b=3","(test where b=3){a}"), + ("SELECT a,b FROM test where b>3","(test where gt(@b,3)){a,b}")] check (sql, tutd) = do --parse SQL - let Right select = parse selectP "test" sql + select <- case parse selectP "test" sql of + Left err -> error (errorBundlePretty err) + Right x -> pure x --parse tutd - Right relExpr = parse relExprP "test" tutd - Right selectAsRelExpr = convert select + relExpr <- case parse relExprP "test" tutd of + Left err -> error (errorBundlePretty err) + Right x -> pure x + selectAsRelExpr <- case convert select of + Left err -> error (show err) + Right x -> pure x print selectAsRelExpr assertEqual (T.unpack sql) selectAsRelExpr relExpr mapM_ check readTests - assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName [Name "test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") + assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") From 6872288eabd1190323c0002e264d300346936edd Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 2 Jul 2023 23:38:41 -0400 Subject: [PATCH 003/170] tests pass checkpoint support case insensitive keywords support asterisk SelectItem conversion support table aliases fix bug in WithName substitutions which should have propagated to RelationalExprAttributeNames --- src/bin/SQL/Interpreter/Base.hs | 6 +- src/bin/SQL/Interpreter/Convert.hs | 192 +++++++++++++++++++++------ src/bin/SQL/Interpreter/Select.hs | 5 +- src/lib/ProjectM36/AttributeNames.hs | 16 +++ src/lib/ProjectM36/Base.hs | 4 +- src/lib/ProjectM36/WithNameExpr.hs | 15 ++- test/SQL/InterpreterTest.hs | 19 ++- 7 files changed, 199 insertions(+), 58 deletions(-) diff --git a/src/bin/SQL/Interpreter/Base.hs b/src/bin/SQL/Interpreter/Base.hs index 06fb276d..d536de58 100644 --- a/src/bin/SQL/Interpreter/Base.hs +++ b/src/bin/SQL/Interpreter/Base.hs @@ -3,7 +3,7 @@ import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as Lex import Data.Void (Void) -import Data.Text as T (Text, singleton, pack, splitOn) +import Data.Text as T (Text, singleton, pack, splitOn, toLower) type Parser = Parsec Void Text @@ -27,7 +27,7 @@ reserveds words' = do -- does not consume trailing spaces qualifiedNameSegment :: Text -> Parser Text -qualifiedNameSegment sym = string' sym +qualifiedNameSegment sym = T.toLower <$> string' sym reservedOp :: Text -> Parser () reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer) @@ -41,7 +41,7 @@ braces = between (symbol "{") (symbol "}") identifier :: Parser Text identifier = do istart <- letterChar <|> char '_' - identifierRemainder istart + toLower <$> identifierRemainder istart identifierRemainder :: Char -> Parser Text identifierRemainder c = do diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 0fa97d43..c1e7c439 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -1,13 +1,17 @@ --convert SQL into relational or database context expressions -{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables, TypeApplications #-} module SQL.Interpreter.Convert where import ProjectM36.Base +import ProjectM36.AttributeNames as A import SQL.Interpreter.Select import Data.Kind (Type) -import Data.Text as T (pack,intercalate,Text) +import Data.Text as T (pack,intercalate,Text,concat) import ProjectM36.Relation import Control.Monad (foldM) import qualified Data.Set as S +import Data.List (foldl') + +import Debug.Trace data SQLError = NotSupportedError T.Text | TypeMismatch AtomType AtomType | @@ -24,56 +28,115 @@ instance SQLConvert Select where projF <- convert (projectionClause sel) case tableExpr sel of Nothing -> pure $ ExistingRelation relationTrue - Just tExpr -> projF <$> convert tExpr + Just tExpr -> do + (rvExpr, withNames) <- convert tExpr + let withF = case withNames of + [] -> id + wnames -> With withNames + pure (withF (projF rvExpr)) +data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set QualifiedProjectionName, + taskRenames :: [(QualifiedProjectionName, AliasName)], + taskExtenders :: [ExtendTupleExpr] + } deriving (Show, Eq) + instance SQLConvert [SelectItem] where type ConverterF [SelectItem] = (RelationalExpr -> RelationalExpr) convert selItems = do - --SQL projections conflate static values to appear in a table with attribute names to include in the resultant relation - let folder :: (RelationalExpr -> RelationalExpr) -> (Int, SelectItem) -> Either SQLError (RelationalExpr -> RelationalExpr) - folder _ (c,selItem) = do - let ext atom mAlias = pure $ Extend (AttributeExtendTupleExpr (attrName' mAlias) (NakedAtomExpr atom)) - --simple projection, no alias - proj :: AttributeName -> Maybe AliasName -> (RelationalExpr -> RelationalExpr) - proj attr Nothing f = Project (AttributeNames (S.singleton attr)) f - proj attr alias f = Rename attr (attrName' alias) (proj attr Nothing f) - attrName' (Just (AliasName nam)) = nam - attrName' Nothing = "attr_" <> T.pack (show c) - case selItem of - (IntegerLiteral i, mAlias) -> ext (IntegerAtom i) mAlias - -- select * - does nothing - (Identifier (QualifiedProjectionName [Asterisk]), Nothing) -> pure id - -- select a, simple, unqualified attribute projection - (Identifier (QualifiedProjectionName [ProjectionName nam]), Nothing) -> pure $ proj nam Nothing - foldM folder id (zip [1::Int ..] selItems) + --SQL projections conflate static values to appear in a table with attribute names to include in the resultant relation + --split the projections and extensions +{- let (projections, extensions) = partition isProjection selItems + isProjection (Identifier{},_) = True + isProjection _ = False-} + let emptyTask = SelectItemsConvertTask { taskProjections = S.empty, + taskRenames = mempty, + taskExtenders = mempty } + attrName' (Just (AliasName nam)) _ = nam + attrName' Nothing c = "attr_" <> T.pack (show c) + + let selItemFolder :: SelectItemsConvertTask -> (Int, SelectItem) -> Either SQLError SelectItemsConvertTask + selItemFolder acc (_, (Identifier (QualifiedProjectionName [Asterisk]), Nothing)) = pure acc + --select a from s + selItemFolder acc (_, (Identifier qpn@(QualifiedProjectionName [ProjectionName pname]), Nothing)) = + pure $ acc { taskProjections = S.insert qpn (taskProjections acc) + } + --select t.a from test as t -- we don't support schemas yet- that would require matching three name components + selItemFolder acc (_, (Identifier qpn@(QualifiedProjectionName [ProjectionName tname, ProjectionName colname]), Nothing)) = + pure $ acc { taskProjections = S.insert qpn (taskProjections acc), + taskRenames = taskRenames acc <> [(QualifiedProjectionName [ProjectionName colname], AliasName (T.intercalate "." [tname,colname]))] } + -- select city as x from s + selItemFolder acc (_, (Identifier qn, Just newName@(AliasName newNameTxt))) = do + pure $ acc { taskProjections = S.insert (QualifiedProjectionName [ProjectionName newNameTxt]) (taskProjections acc), + taskRenames = taskRenames acc <> [(qn, newName)] } + -- select sup.* from s as sup + selItemFolder acc (_, (Identifier qpn@(QualifiedProjectionName [ProjectionName tname, Asterisk]), mAlias)) = + pure $ acc { taskProjections = S.insert qpn (taskProjections acc) } + + selItemFolder acc (c, (scalarExpr, mAlias)) = do + atomExpr <- convert scalarExpr + pure $ acc { taskExtenders = AttributeExtendTupleExpr (attrName' mAlias c) atomExpr : taskExtenders acc } + task <- foldM selItemFolder emptyTask (zip [1::Int ..] selItems) + --apply projections + fProjection <- if S.null (taskProjections task) then + pure id + else do + let projFolder (attrNames, b) (QualifiedProjectionName [ProjectionName nam]) = + pure (S.insert nam attrNames, b) + projFolder (attrNames, b) (QualifiedProjectionName [ProjectionName nameA, ProjectionName nameB]) = + pure $ (S.insert (T.concat [nameA, ".", nameB]) attrNames, b) + projFolder (attrNames, relExprAttributes) (QualifiedProjectionName [ProjectionName tname, Asterisk]) = + pure $ (attrNames, relExprAttributes <> [tname]) + (attrNames, relExprRvs) <- foldM projFolder mempty (S.toList (taskProjections task)) + let attrsProj = A.some (map (\rv -> RelationalExprAttributeNames (RelationVariable rv ())) relExprRvs <> [AttributeNames attrNames]) + pure $ Project attrsProj + -- apply extensions + let fExtended = foldl' (\acc ext -> (Extend ext) . acc) id (taskExtenders task) + -- apply rename + fRenames <- foldM (\acc (qProjName, (AliasName newName)) -> do + oldName <- convert qProjName + pure $ Rename oldName newName . acc) id (taskRenames task) + pure (fExtended . fProjection . fRenames) instance SQLConvert TableExpr where - type ConverterF TableExpr = RelationalExpr + type ConverterF TableExpr = (RelationalExpr, WithNamesBlock) --does not handle non-relational aspects such as offset, order by, or limit convert tExpr = do - fromExpr <- convert (fromClause tExpr) - case whereClause tExpr of + (fromExpr, withExprs) <- convert (fromClause tExpr) + expr' <- case whereClause tExpr of Just whereExpr -> do restrictPredExpr <- convert whereExpr pure $ Restrict restrictPredExpr fromExpr Nothing -> pure fromExpr + pure (expr', withExprs) --group by --having instance SQLConvert [TableRef] where - type ConverterF [TableRef] = RelationalExpr - convert [] = pure (ExistingRelation relationFalse) + -- returns base relation expressions plus top-level renames required + type ConverterF [TableRef] = (RelationalExpr, WithNamesBlock) + convert [] = pure (ExistingRelation relationFalse, []) convert (firstRef:trefs) = do - firstRel <- convert firstRef - foldM joinTRef firstRel trefs + --the first table ref must be a straight RelationVariable + (firstRel, withRenames) <- convert firstRef + expr' <- foldM joinTRef firstRel trefs + pure (expr', withRenames) where + --TODO: if any of the previous relations have overlap in their attribute names, we must change it to prevent a natural join! joinTRef = undefined +-- convert a TableRef in isolation- to be used with the first TableRef only instance SQLConvert TableRef where - type ConverterF TableRef = RelationalExpr + -- return base relation variable expression plus a function to apply top-level rv renames using WithNameExpr + type ConverterF TableRef = (RelationalExpr, WithNamesBlock) + --SELECT x FROM a,_b_ creates a cross join convert (SimpleTableRef (QualifiedName [nam])) = - pure $ RelationVariable nam () + pure (RelationVariable nam (), []) + convert (AliasedTableRef tnam (AliasName newName)) = do + (rv, withNames) <- convert tnam + pure $ (RelationVariable newName (), (WithNameExpr newName (), rv):withNames) + convert x = Left $ NotSupportedError (T.pack (show x)) + instance SQLConvert RestrictionExpr where type ConverterF RestrictionExpr = RestrictionPredicateExpr @@ -87,30 +150,71 @@ instance SQLConvert RestrictionExpr where Identifier i -> wrongType TextAtomType -- could be a better error here BinaryOperator (Identifier a) (QualifiedName ["="]) exprMatch -> --we don't know here if this results in a boolean expression, so we pass it down AttributeEqualityPredicate (attrName' a) <$> convert exprMatch + BinaryOperator exprA qn exprB -> do + a <- convert exprA + b <- convert exprB + f <- lookupFunc qn + pure (AtomExprPredicate (f [a,b])) +-- this could be amended to support more complex expressions such as coalesce by returning an [AtomExpr] -> AtomExpr function +lookupFunc :: QualifiedName -> Either SQLError ([AtomExpr] -> AtomExpr) +lookupFunc qname = + case qname of + QualifiedName [nam] -> + case lookup nam sqlFuncs of + Nothing -> Left $ NoSuchFunction qname + Just match -> pure match + where + f n args = FunctionAtomExpr n args () + sqlFuncs = [(">",f "gt"), + ("<",f "lt"), + (">=",f "gte"), + ("<=",f "lte"), + ("=",f "eq"), + ("!=",f "not_eq"), -- function missing + ("<>",f "not_eq") -- function missing + ] + instance SQLConvert ScalarExpr where type ConverterF ScalarExpr = AtomExpr convert expr = do let naked = pure . NakedAtomExpr - attrName' (QualifiedName ts) = T.intercalate "." ts - sqlFuncs = [(">","gt"), - ("<","lt"), - (">=","gte"), - ("<=","lte"), - ("=","eq"), - ("!=","not_eq"), -- function missing - ("<>", "not_eq") -- function missing - ] case expr of IntegerLiteral i -> naked (IntegerAtom i) DoubleLiteral d -> naked (DoubleAtom d) StringLiteral s -> naked (TextAtom s) - Identifier i -> pure $ AttributeAtomExpr (attrName' i) - BinaryOperator exprA qn@(QualifiedName [op]) exprB -> do + Identifier i -> + AttributeAtomExpr <$> convert i + BinaryOperator exprA qn exprB -> do a <- convert exprA b <- convert exprB - func <- case lookup op sqlFuncs of - Nothing -> Left $ NoSuchFunction qn - Just f -> pure f - pure $ FunctionAtomExpr func [a,b] () + f <- lookupFunc qn + pure $ f [a,b] + +instance SQLConvert ProjectionScalarExpr where + type ConverterF ProjectionScalarExpr = AtomExpr + convert expr = do + let naked = pure . NakedAtomExpr + case expr of + IntegerLiteral i -> naked (IntegerAtom i) + DoubleLiteral d -> naked (DoubleAtom d) + StringLiteral s -> naked (TextAtom s) + Identifier i -> + AttributeAtomExpr <$> convert i + BinaryOperator exprA qn exprB -> do + a <- convert exprA + b <- convert exprB + f <- lookupFunc qn + pure $ f [a,b] + +instance SQLConvert QualifiedName where + type ConverterF QualifiedName = AttributeName + convert (QualifiedName ts) = pure $ T.intercalate "." ts +instance SQLConvert QualifiedProjectionName where + type ConverterF QualifiedProjectionName = AttributeName + convert (QualifiedProjectionName names) = do + let namer (ProjectionName t) = pure t + namer Asterisk = error "wrong asterisk" + names' <- mapM namer names + pure (T.concat names') diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index a09682b3..2d43f72a 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -26,7 +26,6 @@ data QuantifiedComparisonPredicate = QCAny | QCSome | QCAll data TableRef = SimpleTableRef QualifiedName | JoinTableRef JoinType TableRef (Maybe JoinCondition) | AliasedTableRef TableRef AliasName - | QueryTableRef Select deriving (Show, Eq) @@ -85,10 +84,10 @@ data Alias = Alias QualifiedName (Maybe AliasName) deriving (Show, Eq) data QualifiedProjectionName = QualifiedProjectionName [ProjectionName] --dot-delimited reference - deriving (Show, Eq) + deriving (Show, Eq, Ord) data ProjectionName = ProjectionName Text | Asterisk - deriving (Show, Eq) + deriving (Show, Eq, Ord) data QualifiedName = QualifiedName [Text] deriving (Show, Eq) diff --git a/src/lib/ProjectM36/AttributeNames.hs b/src/lib/ProjectM36/AttributeNames.hs index 1eb494b5..7991ffd2 100644 --- a/src/lib/ProjectM36/AttributeNames.hs +++ b/src/lib/ProjectM36/AttributeNames.hs @@ -1,6 +1,7 @@ module ProjectM36.AttributeNames where import ProjectM36.Base import qualified Data.Set as S +import Data.List (foldl') --AttributeNames is a data structure which can represent inverted projection attributes and attribute names derived from relational expressions empty :: AttributeNamesBase a @@ -9,3 +10,18 @@ empty = AttributeNames S.empty all :: AttributeNamesBase a all = InvertedAttributeNames S.empty +-- | Coalesce a bunch of AttributeNames into a single AttributeNames. +some :: Eq a => [AttributeNamesBase a] -> AttributeNamesBase a +some [] = ProjectM36.AttributeNames.all +some [an] = an +some (a:as) = foldl' folder a as + where + folder :: Eq a => AttributeNamesBase a -> AttributeNamesBase a -> AttributeNamesBase a + folder acc names = + case acc of + AttributeNames an | S.null an -> names + acc' -> if names == empty then + acc + else + UnionAttributeNames acc' names + diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 3232c42f..ead15d38 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -252,7 +252,9 @@ data RelationalExprBase a = deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable) instance Hashable RelationalExpr - + +type WithNamesBlock = [(WithNameExpr, RelationalExpr)] + data WithNameExprBase a = WithNameExpr RelVarName a deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable, Hashable) diff --git a/src/lib/ProjectM36/WithNameExpr.hs b/src/lib/ProjectM36/WithNameExpr.hs index b12eae0d..2650136a 100644 --- a/src/lib/ProjectM36/WithNameExpr.hs +++ b/src/lib/ProjectM36/WithNameExpr.hs @@ -20,7 +20,7 @@ substituteWithNameMacros macros e@(RelationVariable rvname tid) = [(_,replacement)] -> replacement _ -> error "more than one macro matched!" substituteWithNameMacros macros (Project attrs expr) = - Project attrs (substituteWithNameMacros macros expr) + Project (substituteWithNameMacrosAttributeNames macros attrs) (substituteWithNameMacros macros expr) substituteWithNameMacros macros (Union exprA exprB) = Union (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB) substituteWithNameMacros macros (Join exprA exprB) = @@ -84,3 +84,16 @@ substituteWithNameMacrosAtomExpr macros atomExpr = RelationAtomExpr (substituteWithNameMacros macros reExpr) ConstructedAtomExpr dconsName atomExprs tid -> ConstructedAtomExpr dconsName (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid + +substituteWithNameMacrosAttributeNames :: WithNameAssocs -> GraphRefAttributeNames -> GraphRefAttributeNames +substituteWithNameMacrosAttributeNames macros attrNames = + case attrNames of + AttributeNames{} -> attrNames + InvertedAttributeNames{} -> attrNames + UnionAttributeNames a b -> + UnionAttributeNames (substituteWithNameMacrosAttributeNames macros a) (substituteWithNameMacrosAttributeNames macros b) + IntersectAttributeNames a b -> + IntersectAttributeNames (substituteWithNameMacrosAttributeNames macros a) (substituteWithNameMacrosAttributeNames macros b) + RelationalExprAttributeNames relExpr -> + RelationalExprAttributeNames (substituteWithNameMacros macros relExpr) + diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 81726512..07da6423 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -21,21 +21,28 @@ testSelect = TestCase $ do readTests = [("SELECT * FROM test", "test"), ("SELECT a FROM test", "test{a}"), ("SELECT a FROM test where b=3","(test where b=3){a}"), - ("SELECT a,b FROM test where b>3","(test where gt(@b,3)){a,b}")] + ("SELECT a,b FROM test where b>3","(test where gt(@b,3)){a,b}"), + ("SELECT a,b,10 FROM test","test{a,b}:{attr_3:=10}"), + ("SELECT a AS x FROM test","(test rename {a as x}){x}"), + ("sElECt A aS X FRoM TeST","(test rename {a as x}){x}"), + ("SELECT sup.city FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`})"), + ("SELECT sup.city,sup.sname FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`})"), + ("SELECT sup.* FROM s as sup","with (sup as s) (sup{all from sup})") + ] check (sql, tutd) = do --parse SQL - select <- case parse selectP "test" sql of + select <- case parse (selectP <* eof) "test" sql of Left err -> error (errorBundlePretty err) - Right x -> pure x + Right x -> print x >> pure x --parse tutd - relExpr <- case parse relExprP "test" tutd of + relExpr <- case parse (relExprP <* eof) "test" tutd of Left err -> error (errorBundlePretty err) Right x -> pure x selectAsRelExpr <- case convert select of Left err -> error (show err) Right x -> pure x - print selectAsRelExpr - assertEqual (T.unpack sql) selectAsRelExpr relExpr + print ("selectAsRelExpr", selectAsRelExpr) + assertEqual (T.unpack sql) relExpr selectAsRelExpr mapM_ check readTests assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") From 4b7bbd207f7f284ff1c9a920efa872551a67c67d Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 3 Jul 2023 01:06:34 -0400 Subject: [PATCH 004/170] support natural join --- src/bin/SQL/Interpreter/Convert.hs | 16 +++++++++++++--- src/bin/SQL/Interpreter/Select.hs | 18 ++++++++++++++++-- test/SQL/InterpreterTest.hs | 5 +++-- 3 files changed, 32 insertions(+), 7 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index c1e7c439..68e8ffeb 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -119,11 +119,21 @@ instance SQLConvert [TableRef] where convert (firstRef:trefs) = do --the first table ref must be a straight RelationVariable (firstRel, withRenames) <- convert firstRef - expr' <- foldM joinTRef firstRel trefs - pure (expr', withRenames) + (expr', withRenames') <- foldM joinTRef (firstRel, withRenames) trefs + pure (expr', withRenames') where --TODO: if any of the previous relations have overlap in their attribute names, we must change it to prevent a natural join! - joinTRef = undefined + joinTRef (rvA,withRenames) tref = + case tref of + NaturalJoinTableRef jtref -> do + -- then natural join is the only type of join which the relational algebra supports natively + (rvB, withRenames') <- convert jtref + pure $ (Join rvA rvB, withRenames <> withRenames') + --CrossJoinTableRef jtref -> do + --rename all columns to prefix them with a generated alias to prevent any natural join occurring, then perform normal join + -- we need the type to get all the attribute names for both relexprs + --typeForGraphRefRelationalExpr + -- convert a TableRef in isolation- to be used with the first TableRef only instance SQLConvert TableRef where diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 2d43f72a..9aecdc43 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -24,7 +24,12 @@ data QuantifiedComparisonPredicate = QCAny | QCSome | QCAll deriving (Show,Eq) data TableRef = SimpleTableRef QualifiedName - | JoinTableRef JoinType TableRef (Maybe JoinCondition) + | InnerJoinTableRef TableRef JoinCondition + | RightOuterJoinTableRef TableRef JoinCondition + | LeftOuterJoinTableRef TableRef JoinCondition + | FullOuterJoinTableRef TableRef JoinCondition + | CrossJoinTableRef TableRef + | NaturalJoinTableRef TableRef | AliasedTableRef TableRef AliasName | QueryTableRef Select deriving (Show, Eq) @@ -141,7 +146,16 @@ fromP = reserved "from" *> ((:) <$> nonJoinTref <*> sepByComma joinP) try (AliasedTableRef <$> simpleRef <*> (reserved "as" *> aliasNameP)), simpleRef] simpleRef = SimpleTableRef <$> qualifiedNameP - joinP = JoinTableRef <$> joinTypeP <*> nonJoinTref <*> optional joinConditionP + joinP = do + joinType <- joinTypeP + tref <- nonJoinTref + case joinType of -- certain join types require join conditions, others not + InnerJoin -> InnerJoinTableRef tref <$> joinConditionP + RightOuterJoin -> RightOuterJoinTableRef tref <$> joinConditionP + LeftOuterJoin -> LeftOuterJoinTableRef tref <$> joinConditionP + FullOuterJoin -> FullOuterJoinTableRef tref <$> joinConditionP + CrossJoin -> pure $ CrossJoinTableRef tref + NaturalJoin -> pure $ NaturalJoinTableRef tref joinConditionP :: Parser JoinCondition joinConditionP = do diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 07da6423..3a800f74 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -18,7 +18,7 @@ testSelect :: Test testSelect = TestCase $ do -- check that SQL and tutd compile to same thing let p tin = parse selectP "test" tin - readTests = [("SELECT * FROM test", "test"), + readTests = [{-("SELECT * FROM test", "test"), ("SELECT a FROM test", "test{a}"), ("SELECT a FROM test where b=3","(test where b=3){a}"), ("SELECT a,b FROM test where b>3","(test where gt(@b,3)){a,b}"), @@ -27,7 +27,8 @@ testSelect = TestCase $ do ("sElECt A aS X FRoM TeST","(test rename {a as x}){x}"), ("SELECT sup.city FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`})"), ("SELECT sup.city,sup.sname FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`})"), - ("SELECT sup.* FROM s as sup","with (sup as s) (sup{all from sup})") + ("SELECT sup.* FROM s as sup","with (sup as s) (sup{all from sup})"),-} + ("SELECT * FROM s NATURAL JOIN sp","s join sp") ] check (sql, tutd) = do --parse SQL From e56ff14b33cb27f260f878de25ded0f60dedec92 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 18 Jul 2023 23:35:04 -0400 Subject: [PATCH 005/170] WIP compilation checkpoint --- project-m36.cabal | 5 +- src/bin/SQL/Interpreter/Base.hs | 2 +- src/bin/SQL/Interpreter/Convert.hs | 178 +++++++++++++++++++++-------- src/bin/SQL/Interpreter/Select.hs | 65 ++++++----- src/lib/ProjectM36/Attribute.hs | 3 + src/lib/ProjectM36/Base.hs | 8 +- src/lib/ProjectM36/WithNameExpr.hs | 19 ++- test/SQL/InterpreterTest.hs | 26 ++++- 8 files changed, 218 insertions(+), 88 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index 707e9b51..a314cee7 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -195,7 +195,8 @@ Executable tutd base16-bytestring >= 1.0.0.0, http-conduit, modern-uri, - http-types + http-types, + recursion-schemes Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, @@ -319,7 +320,7 @@ Test-Suite test-sql type: exitcode-stdio-1.0 main-is: SQL/InterpreterTest.hs Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, SQL.Interpreter.Convert - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific, recursion-schemes Test-Suite test-tutoriald import: commontest diff --git a/src/bin/SQL/Interpreter/Base.hs b/src/bin/SQL/Interpreter/Base.hs index d536de58..8888c5b7 100644 --- a/src/bin/SQL/Interpreter/Base.hs +++ b/src/bin/SQL/Interpreter/Base.hs @@ -85,7 +85,7 @@ quotedIdentifier = T.pack <$> (doubleQuote *> many (escapedDoubleQuote <|> notDoubleQuote) <* doubleQuote) where doubleQuote = char '"' - escapedDoubleQuote = char '"' >> char '"' + escapedDoubleQuote = chunk "\"\"" *> pure '"' notDoubleQuote = satisfy ('"' /=) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 68e8ffeb..c77a07cd 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -2,7 +2,10 @@ {-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables, TypeApplications #-} module SQL.Interpreter.Convert where import ProjectM36.Base +import ProjectM36.Error import ProjectM36.AttributeNames as A +import ProjectM36.Attribute as A +import qualified ProjectM36.WithNameExpr as W import SQL.Interpreter.Select import Data.Kind (Type) import Data.Text as T (pack,intercalate,Text,concat) @@ -10,29 +13,33 @@ import ProjectM36.Relation import Control.Monad (foldM) import qualified Data.Set as S import Data.List (foldl') +import qualified Data.Functor.Foldable as Fold import Debug.Trace data SQLError = NotSupportedError T.Text | TypeMismatch AtomType AtomType | - NoSuchFunction QualifiedName + NoSuchFunction QualifiedName | + SQLRelationalError RelationalError deriving (Show, Eq) +type TypeForRelExprF = RelationalExpr -> Either RelationalError Relation + class SQLConvert sqlexpr where type ConverterF sqlexpr :: Type - convert :: sqlexpr -> Either SQLError (ConverterF sqlexpr) + convert :: TypeForRelExprF -> sqlexpr -> Either SQLError (ConverterF sqlexpr) instance SQLConvert Select where type ConverterF Select = RelationalExpr - convert sel = do - projF <- convert (projectionClause sel) + convert typeF sel = do + projF <- convert typeF (projectionClause sel) case tableExpr sel of Nothing -> pure $ ExistingRelation relationTrue Just tExpr -> do - (rvExpr, withNames) <- convert tExpr + (rvExpr, withNames) <- convert typeF tExpr let withF = case withNames of [] -> id - wnames -> With withNames + _ -> With withNames pure (withF (projF rvExpr)) data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set QualifiedProjectionName, @@ -42,7 +49,7 @@ data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set instance SQLConvert [SelectItem] where type ConverterF [SelectItem] = (RelationalExpr -> RelationalExpr) - convert selItems = do + convert typeF selItems = do --SQL projections conflate static values to appear in a table with attribute names to include in the resultant relation --split the projections and extensions {- let (projections, extensions) = partition isProjection selItems @@ -57,7 +64,7 @@ instance SQLConvert [SelectItem] where let selItemFolder :: SelectItemsConvertTask -> (Int, SelectItem) -> Either SQLError SelectItemsConvertTask selItemFolder acc (_, (Identifier (QualifiedProjectionName [Asterisk]), Nothing)) = pure acc --select a from s - selItemFolder acc (_, (Identifier qpn@(QualifiedProjectionName [ProjectionName pname]), Nothing)) = + selItemFolder acc (_, (Identifier qpn@(QualifiedProjectionName [ProjectionName _]), Nothing)) = pure $ acc { taskProjections = S.insert qpn (taskProjections acc) } --select t.a from test as t -- we don't support schemas yet- that would require matching three name components @@ -69,11 +76,11 @@ instance SQLConvert [SelectItem] where pure $ acc { taskProjections = S.insert (QualifiedProjectionName [ProjectionName newNameTxt]) (taskProjections acc), taskRenames = taskRenames acc <> [(qn, newName)] } -- select sup.* from s as sup - selItemFolder acc (_, (Identifier qpn@(QualifiedProjectionName [ProjectionName tname, Asterisk]), mAlias)) = + selItemFolder acc (_, (Identifier qpn@(QualifiedProjectionName [ProjectionName _, Asterisk]), Nothing)) = pure $ acc { taskProjections = S.insert qpn (taskProjections acc) } selItemFolder acc (c, (scalarExpr, mAlias)) = do - atomExpr <- convert scalarExpr + atomExpr <- convert typeF scalarExpr pure $ acc { taskExtenders = AttributeExtendTupleExpr (attrName' mAlias c) atomExpr : taskExtenders acc } task <- foldM selItemFolder emptyTask (zip [1::Int ..] selItems) --apply projections @@ -93,18 +100,18 @@ instance SQLConvert [SelectItem] where let fExtended = foldl' (\acc ext -> (Extend ext) . acc) id (taskExtenders task) -- apply rename fRenames <- foldM (\acc (qProjName, (AliasName newName)) -> do - oldName <- convert qProjName + oldName <- convert typeF qProjName pure $ Rename oldName newName . acc) id (taskRenames task) pure (fExtended . fProjection . fRenames) instance SQLConvert TableExpr where - type ConverterF TableExpr = (RelationalExpr, WithNamesBlock) + type ConverterF TableExpr = (RelationalExpr, WithNamesAssocs) --does not handle non-relational aspects such as offset, order by, or limit - convert tExpr = do - (fromExpr, withExprs) <- convert (fromClause tExpr) + convert typeF tExpr = do + (fromExpr, withExprs) <- convert typeF (fromClause tExpr) expr' <- case whereClause tExpr of Just whereExpr -> do - restrictPredExpr <- convert whereExpr + restrictPredExpr <- convert typeF whereExpr pure $ Restrict restrictPredExpr fromExpr Nothing -> pure fromExpr pure (expr', withExprs) @@ -114,43 +121,111 @@ instance SQLConvert TableExpr where instance SQLConvert [TableRef] where -- returns base relation expressions plus top-level renames required - type ConverterF [TableRef] = (RelationalExpr, WithNamesBlock) - convert [] = pure (ExistingRelation relationFalse, []) - convert (firstRef:trefs) = do + type ConverterF [TableRef] = (RelationalExpr, WithNamesAssocs) + convert _ [] = pure (ExistingRelation relationFalse, []) + convert typeF (firstRef:trefs) = do --the first table ref must be a straight RelationVariable - (firstRel, withRenames) <- convert firstRef - (expr', withRenames') <- foldM joinTRef (firstRel, withRenames) trefs + (firstRel, withRenames) <- convert typeF firstRef + (expr', withRenames') <- foldM joinTRef (firstRel, withRenames) (zip [1..] trefs) pure (expr', withRenames') where - --TODO: if any of the previous relations have overlap in their attribute names, we must change it to prevent a natural join! - joinTRef (rvA,withRenames) tref = + --TODO: if any of the previous relations have overlap in their attribute names, we must change it to prevent a natural join! + joinTRef (rvA,withRenames) (c,tref) = do + let renamerFolder x expr old_name = + let new_name = T.concat [old_name, "_", x, T.pack (show c)] + in + pure $ Rename old_name new_name expr case tref of NaturalJoinTableRef jtref -> do -- then natural join is the only type of join which the relational algebra supports natively - (rvB, withRenames') <- convert jtref + (rvB, withRenames') <- convert typeF jtref pure $ (Join rvA rvB, withRenames <> withRenames') - --CrossJoinTableRef jtref -> do + CrossJoinTableRef jtref -> do --rename all columns to prefix them with a generated alias to prevent any natural join occurring, then perform normal join -- we need the type to get all the attribute names for both relexprs - --typeForGraphRefRelationalExpr - + (rvB, withRenames') <- convert typeF jtref + case typeF rvA of + Left err -> Left (SQLRelationalError err) + Right typeA -> + case typeF rvB of + Left err -> Left (SQLRelationalError err) + Right typeB -> do + let attrsA = A.attributeNameSet (attributes typeA) + attrsB = A.attributeNameSet (attributes typeB) + attrsIntersection = S.intersection attrsA attrsB + --find intersection of attributes and rename all of them with prefix 'expr'+c+'.' + traceShowM ("cross gonk", attrsIntersection) + exprA <- foldM (renamerFolder "a") rvA (S.toList attrsIntersection) + pure (Join exprA rvB, withRenames') + InnerJoinTableRef jtref (JoinUsing qnames) -> do + (rvB, withRenames') <- convert typeF jtref + jCondAttrs <- S.fromList <$> mapM (convert typeF) qnames + (attrsIntersection, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB + --rename attributes which are not part of the join condition + let attrsToRename = S.difference attrsIntersection jCondAttrs + traceShowM ("inner", attrsToRename, attrsIntersection, jCondAttrs) + exprA <- foldM (renamerFolder "a") rvA (S.toList attrsToRename) + pure (Join exprA rvB, withRenames') + InnerJoinTableRef jtref (JoinOn sexpr) -> do + --create a cross join but extend with the boolean sexpr + --extend the table with the join conditions, then join on those + --exception: for simple attribute equality, use regular join renames using JoinOn logic + (rvB, withRenames') <- convert typeF jtref + --extract all table aliases to create a remapping for SQL names discovered in the sexpr + (commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB + let sexpr' = renameIdentifier renamer sexpr + renamer n@(QualifiedName [tableAlias,attr]) = --lookup prefixed with table alias + case W.lookup tableAlias withRenames' of + Nothing -> QualifiedName [attr]-- the table was not renamed, but the attribute may have been renamed- how do we know at this point when the sexpr' converter hasn't run yet?! + Just found -> error (show (tableAlias, found)) + renamer n@(QualifiedName [attr]) = error (show n) + joinRe <- convert typeF sexpr' + + --rename all common attrs and use the new names in the join condition + exprA <- foldM (renamerFolder "a") rvA (S.toList commonAttrs) + exprB <- foldM (renamerFolder "b") rvB (S.toList commonAttrs) + let allAttrs = S.union attrsA attrsB + firstAvailableName c allAttrs' = + let new_name = T.pack ("join_" <> show c) in + if S.member new_name allAttrs' then + firstAvailableName (c + 1) allAttrs' + else + new_name + extender = AttributeExtendTupleExpr (firstAvailableName 1 allAttrs) joinRe + pure (Join (Extend extender exprA) exprB, withRenames') + + +-- | Used in join condition detection necessary for renames to enable natural joins. +commonAttributeNames :: TypeForRelExprF -> RelationalExpr -> RelationalExpr -> Either SQLError (S.Set AttributeName, S.Set AttributeName, S.Set AttributeName) +commonAttributeNames typeF rvA rvB = + case typeF rvA of + Left err -> Left (SQLRelationalError err) + Right typeA -> + case typeF rvB of + Left err -> Left (SQLRelationalError err) + Right typeB -> do + let attrsA = A.attributeNameSet (attributes typeA) + attrsB = A.attributeNameSet (attributes typeB) + pure $ (S.intersection attrsA attrsB, attrsA, attrsB) + + -- convert a TableRef in isolation- to be used with the first TableRef only instance SQLConvert TableRef where -- return base relation variable expression plus a function to apply top-level rv renames using WithNameExpr - type ConverterF TableRef = (RelationalExpr, WithNamesBlock) + type ConverterF TableRef = (RelationalExpr, WithNamesAssocs) --SELECT x FROM a,_b_ creates a cross join - convert (SimpleTableRef (QualifiedName [nam])) = + convert _ (SimpleTableRef (QualifiedName [nam])) = pure (RelationVariable nam (), []) - convert (AliasedTableRef tnam (AliasName newName)) = do - (rv, withNames) <- convert tnam + convert typeF (AliasedTableRef tnam (AliasName newName)) = do + (rv, withNames) <- convert typeF tnam pure $ (RelationVariable newName (), (WithNameExpr newName (), rv):withNames) - convert x = Left $ NotSupportedError (T.pack (show x)) + convert _ x = Left $ NotSupportedError (T.pack (show x)) instance SQLConvert RestrictionExpr where type ConverterF RestrictionExpr = RestrictionPredicateExpr - convert (RestrictionExpr rexpr) = do + convert typeF (RestrictionExpr rexpr) = do let wrongType t = Left $ TypeMismatch t BoolAtomType --must be boolean expression attrName' (QualifiedName ts) = T.intercalate "." ts case rexpr of @@ -159,10 +234,10 @@ instance SQLConvert RestrictionExpr where StringLiteral{} -> wrongType TextAtomType Identifier i -> wrongType TextAtomType -- could be a better error here BinaryOperator (Identifier a) (QualifiedName ["="]) exprMatch -> --we don't know here if this results in a boolean expression, so we pass it down - AttributeEqualityPredicate (attrName' a) <$> convert exprMatch + AttributeEqualityPredicate (attrName' a) <$> convert typeF exprMatch BinaryOperator exprA qn exprB -> do - a <- convert exprA - b <- convert exprB + a <- convert typeF exprA + b <- convert typeF exprB f <- lookupFunc qn pure (AtomExprPredicate (f [a,b])) @@ -187,44 +262,57 @@ lookupFunc qname = instance SQLConvert ScalarExpr where type ConverterF ScalarExpr = AtomExpr - convert expr = do + convert typeF expr = do let naked = pure . NakedAtomExpr case expr of IntegerLiteral i -> naked (IntegerAtom i) DoubleLiteral d -> naked (DoubleAtom d) StringLiteral s -> naked (TextAtom s) Identifier i -> - AttributeAtomExpr <$> convert i + AttributeAtomExpr <$> convert typeF i BinaryOperator exprA qn exprB -> do - a <- convert exprA - b <- convert exprB + a <- convert typeF exprA + b <- convert typeF exprB f <- lookupFunc qn pure $ f [a,b] instance SQLConvert ProjectionScalarExpr where type ConverterF ProjectionScalarExpr = AtomExpr - convert expr = do + convert typeF expr = do let naked = pure . NakedAtomExpr case expr of IntegerLiteral i -> naked (IntegerAtom i) DoubleLiteral d -> naked (DoubleAtom d) StringLiteral s -> naked (TextAtom s) Identifier i -> - AttributeAtomExpr <$> convert i + AttributeAtomExpr <$> convert typeF i BinaryOperator exprA qn exprB -> do - a <- convert exprA - b <- convert exprB + a <- convert typeF exprA + b <- convert typeF exprB f <- lookupFunc qn pure $ f [a,b] instance SQLConvert QualifiedName where type ConverterF QualifiedName = AttributeName - convert (QualifiedName ts) = pure $ T.intercalate "." ts + convert _ (QualifiedName ts) = pure $ T.intercalate "." ts + +instance SQLConvert UnqualifiedName where + type ConverterF UnqualifiedName = AttributeName + convert _ (UnqualifiedName t) = pure t instance SQLConvert QualifiedProjectionName where type ConverterF QualifiedProjectionName = AttributeName - convert (QualifiedProjectionName names) = do + convert _ (QualifiedProjectionName names) = do let namer (ProjectionName t) = pure t namer Asterisk = error "wrong asterisk" names' <- mapM namer names pure (T.concat names') + +-- | Used to remap SQL qualified names to new names to prevent conflicts in join conditions. +renameIdentifier :: (QualifiedName -> QualifiedName) -> ScalarExpr -> ScalarExpr +renameIdentifier renamer sexpr = Fold.cata renamer' sexpr + where + renamer' :: ScalarExprBaseF QualifiedName ScalarExpr -> ScalarExpr + renamer' (IdentifierF n) = Identifier (renamer n) + renamer' x = Fold.embed x + diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 9aecdc43..98dd5f96 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, DeriveTraversable #-} module SQL.Interpreter.Select where import Text.Megaparsec import Text.Megaparsec.Char @@ -6,6 +7,7 @@ import SQL.Interpreter.Base import Data.Text (Text, splitOn) import qualified Data.Text as T import Data.Functor +import Data.Functor.Foldable.TH -- we use an intermediate data structure because it may need to be probed into order to create a proper relational expression data Select = Select { distinctness :: Maybe Distinctness, @@ -38,28 +40,29 @@ data TableRef = SimpleTableRef QualifiedName type ProjectionScalarExpr = ScalarExprBase QualifiedProjectionName type ScalarExpr = ScalarExprBase QualifiedName -data ScalarExprBase n = IntegerLiteral Integer - | DoubleLiteral Double - | StringLiteral Text - -- | Interval - | Identifier n - | BinaryOperator (ScalarExprBase n) QualifiedName (ScalarExprBase n) - | PrefixOperator QualifiedName (ScalarExprBase n) - | PostfixOperator (ScalarExprBase n) QualifiedName - | BetweenOperator (ScalarExprBase n) (ScalarExprBase n) (ScalarExprBase n) - | FunctionApplication QualifiedName (ScalarExprBase n) - | CaseExpr { caseWhens :: [([ScalarExprBase n],ScalarExprBase n)], - caseElse :: Maybe (ScalarExprBase n) } - | QuantifiedComparison { qcExpr :: (ScalarExprBase n), - qcOperator :: ComparisonOperator, - qcPredicate :: QuantifiedComparisonPredicate, - qcQuery :: Select } - - | InExpr InFlag (ScalarExprBase n) InPredicateValue - -- | ExistsSubQuery Select - -- | UniqueSubQuery Select - -- | ScalarSubQuery Select - deriving (Show, Eq) +data ScalarExprBase n = + IntegerLiteral Integer + | DoubleLiteral Double + | StringLiteral Text + -- | Interval + | Identifier n + | BinaryOperator (ScalarExprBase n) QualifiedName (ScalarExprBase n) + | PrefixOperator QualifiedName (ScalarExprBase n) + | PostfixOperator (ScalarExprBase n) QualifiedName + | BetweenOperator (ScalarExprBase n) (ScalarExprBase n) (ScalarExprBase n) + | FunctionApplication QualifiedName (ScalarExprBase n) + | CaseExpr { caseWhens :: [([ScalarExprBase n],ScalarExprBase n)], + caseElse :: Maybe (ScalarExprBase n) } + | QuantifiedComparison { qcExpr :: (ScalarExprBase n), + qcOperator :: ComparisonOperator, + qcPredicate :: QuantifiedComparisonPredicate, + qcQuery :: Select } + + | InExpr InFlag (ScalarExprBase n) InPredicateValue + -- | ExistsSubQuery Select + -- | UniqueSubQuery Select + -- | ScalarSubQuery Select + deriving (Show, Eq) data InPredicateValue = InList [ScalarExpr] | InQueryExpr Select | InScalarExpr ScalarExpr deriving (Eq, Show) @@ -82,7 +85,7 @@ data NullsOrder = NullsFirst | NullsLast data JoinType = InnerJoin | RightOuterJoin | LeftOuterJoin | FullOuterJoin | CrossJoin | NaturalJoin deriving (Show, Eq) -data JoinCondition = JoinOn ScalarExpr | JoinUsing [QualifiedName] +data JoinCondition = JoinOn ScalarExpr | JoinUsing [UnqualifiedName] deriving (Show, Eq) data Alias = Alias QualifiedName (Maybe AliasName) @@ -97,6 +100,9 @@ data ProjectionName = ProjectionName Text | Asterisk data QualifiedName = QualifiedName [Text] deriving (Show, Eq) +data UnqualifiedName = UnqualifiedName Text + deriving (Show, Eq) + newtype AliasName = AliasName Text deriving (Show, Eq) @@ -160,7 +166,7 @@ fromP = reserved "from" *> ((:) <$> nonJoinTref <*> sepByComma joinP) joinConditionP :: Parser JoinCondition joinConditionP = do (JoinOn <$> (reserved "on" *> scalarExprP)) <|> - JoinUsing <$> (reserved "using" *> parens (sepBy1 qualifiedNameP comma)) + JoinUsing <$> (reserved "using" *> parens (sepBy1 unqualifiedNameP comma)) joinTypeP :: Parser JoinType joinTypeP = choice [reserveds "cross join" $> CrossJoin, @@ -200,9 +206,6 @@ nameP = quotedIdentifier <|> identifier aliasNameP :: Parser AliasName aliasNameP = AliasName <$> (quotedIdentifier <|> identifier) ---qualifiedNameP :: Parser QualifiedName ---qualifiedNameP = - scalarExprP :: QualifiedNameP a => Parser (ScalarExprBase a) scalarExprP = E.makeExprParser scalarTermP scalarExprOp @@ -242,7 +245,7 @@ scalarExprOp = qualifiedOperatorP :: Text -> Parser QualifiedName qualifiedOperatorP sym = - QualifiedName <$> segmentsP (splitOn "." sym) + QualifiedName <$> segmentsP (splitOn "." sym) <* spaceConsumer where segmentsP :: [Text] -> Parser [Text] segmentsP segments = case segments of @@ -350,9 +353,15 @@ instance QualifiedNameP QualifiedProjectionName where instance QualifiedNameP QualifiedName where qualifiedNameP = QualifiedName <$> sepBy1 nameP (char '.') +-- | For use where qualified names need not apply (such as in USING (...) clause) +unqualifiedNameP :: Parser UnqualifiedName +unqualifiedNameP = UnqualifiedName <$> nameP + limitP :: Parser (Maybe Integer) limitP = optional (reserved "limit" *> integer) offsetP :: Parser (Maybe Integer) offsetP = optional (reserved "offset" *> integer) +makeBaseFunctor ''ScalarExprBase + diff --git a/src/lib/ProjectM36/Attribute.hs b/src/lib/ProjectM36/Attribute.hs index 1da05542..2bd443b1 100644 --- a/src/lib/ProjectM36/Attribute.hs +++ b/src/lib/ProjectM36/Attribute.hs @@ -172,6 +172,9 @@ attributeNameSet attrs = S.fromList $ V.toList $ V.map (\(Attribute name _) -> n attributeNames :: Attributes -> V.Vector AttributeName attributeNames attrs = V.map attributeName (attributesVec attrs) +attributeNamesList :: Attributes -> [AttributeName] +attributeNamesList = V.toList . attributeNames + --checks if set s1 is wholly contained in the set s2 attributesContained :: Attributes -> Attributes -> Bool attributesContained attrs1 attrs2 = attributeNamesContained (attributeNameSet attrs1) (attributeNameSet attrs2) diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index ead15d38..219cacaf 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -253,10 +253,14 @@ data RelationalExprBase a = instance Hashable RelationalExpr -type WithNamesBlock = [(WithNameExpr, RelationalExpr)] +type WithNamesAssocs = WithNamesAssocsBase () + +type WithNamesAssocsBase a = [(WithNameExprBase a, RelationalExprBase a)] + +type GraphRefWithNameAssocs = [(GraphRefWithNameExpr, GraphRefRelationalExpr)] data WithNameExprBase a = WithNameExpr RelVarName a - deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable, Hashable) + deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable, Hashable) type WithNameExpr = WithNameExprBase () diff --git a/src/lib/ProjectM36/WithNameExpr.hs b/src/lib/ProjectM36/WithNameExpr.hs index 2650136a..622a9e6a 100644 --- a/src/lib/ProjectM36/WithNameExpr.hs +++ b/src/lib/ProjectM36/WithNameExpr.hs @@ -1,12 +1,18 @@ module ProjectM36.WithNameExpr where import ProjectM36.Base +import Data.List (find) -- substitute all instances of With-based macros to remove macro context -- ideally, we would use a different relational expr type to "prove" that the with macros can no longer exist -type WithNameAssocs = [(GraphRefWithNameExpr, GraphRefRelationalExpr)] + +-- | +lookup :: RelVarName -> WithNamesAssocsBase a -> Maybe (RelationalExprBase a) +lookup matchrv assocs = + snd <$> find (\(WithNameExpr rv _, _) -> rv == matchrv) assocs + -- | Drop macros into the relational expression wherever they are referenced. substituteWithNameMacros :: - WithNameAssocs -> + GraphRefWithNameAssocs -> GraphRefRelationalExpr -> GraphRefRelationalExpr substituteWithNameMacros _ e@MakeRelationFromExprs{} = e @@ -51,7 +57,7 @@ substituteWithNameMacros macros (With moreMacros expr) = substituteWithNameMacros newMacros expr -substituteWithNameMacrosRestrictionPredicate :: WithNameAssocs -> GraphRefRestrictionPredicateExpr -> GraphRefRestrictionPredicateExpr +substituteWithNameMacrosRestrictionPredicate :: GraphRefWithNameAssocs -> GraphRefRestrictionPredicateExpr -> GraphRefRestrictionPredicateExpr substituteWithNameMacrosRestrictionPredicate macros pred' = let sub = substituteWithNameMacrosRestrictionPredicate macros in case pred' of @@ -69,11 +75,11 @@ substituteWithNameMacrosRestrictionPredicate macros pred' = AttributeEqualityPredicate attrName atomExpr -> AttributeEqualityPredicate attrName (substituteWithNameMacrosAtomExpr macros atomExpr) -substituteWitNameMacrosExtendTupleExpr :: WithNameAssocs -> GraphRefExtendTupleExpr -> GraphRefExtendTupleExpr +substituteWitNameMacrosExtendTupleExpr :: GraphRefWithNameAssocs -> GraphRefExtendTupleExpr -> GraphRefExtendTupleExpr substituteWitNameMacrosExtendTupleExpr macros (AttributeExtendTupleExpr attrName atomExpr) = AttributeExtendTupleExpr attrName (substituteWithNameMacrosAtomExpr macros atomExpr) -substituteWithNameMacrosAtomExpr :: WithNameAssocs -> GraphRefAtomExpr -> GraphRefAtomExpr +substituteWithNameMacrosAtomExpr :: GraphRefWithNameAssocs -> GraphRefAtomExpr -> GraphRefAtomExpr substituteWithNameMacrosAtomExpr macros atomExpr = case atomExpr of e@AttributeAtomExpr{} -> e @@ -85,7 +91,7 @@ substituteWithNameMacrosAtomExpr macros atomExpr = ConstructedAtomExpr dconsName atomExprs tid -> ConstructedAtomExpr dconsName (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid -substituteWithNameMacrosAttributeNames :: WithNameAssocs -> GraphRefAttributeNames -> GraphRefAttributeNames +substituteWithNameMacrosAttributeNames :: GraphRefWithNameAssocs -> GraphRefAttributeNames -> GraphRefAttributeNames substituteWithNameMacrosAttributeNames macros attrNames = case attrNames of AttributeNames{} -> attrNames @@ -96,4 +102,5 @@ substituteWithNameMacrosAttributeNames macros attrNames = IntersectAttributeNames (substituteWithNameMacrosAttributeNames macros a) (substituteWithNameMacrosAttributeNames macros b) RelationalExprAttributeNames relExpr -> RelationalExprAttributeNames (substituteWithNameMacros macros relExpr) + diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 3a800f74..0dbbd925 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -2,6 +2,11 @@ import SQL.Interpreter.Select import SQL.Interpreter.Convert import TutorialD.Interpreter.RelationalExpr +import ProjectM36.RelationalExpression +import ProjectM36.TransactionGraph +import ProjectM36.DateExamples +import ProjectM36.NormalizeExpr +import ProjectM36.Base import System.Exit import Test.HUnit import Text.Megaparsec @@ -17,6 +22,7 @@ main = do testSelect :: Test testSelect = TestCase $ do -- check that SQL and tutd compile to same thing + (tgraph,transId) <- freshTransactionGraph dateExamples let p tin = parse selectP "test" tin readTests = [{-("SELECT * FROM test", "test"), ("SELECT a FROM test", "test{a}"), @@ -27,9 +33,20 @@ testSelect = TestCase $ do ("sElECt A aS X FRoM TeST","(test rename {a as x}){x}"), ("SELECT sup.city FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`})"), ("SELECT sup.city,sup.sname FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`})"), - ("SELECT sup.* FROM s as sup","with (sup as s) (sup{all from sup})"),-} - ("SELECT * FROM s NATURAL JOIN sp","s join sp") + ("SELECT sup.* FROM s as sup","with (sup as s) (sup{all from sup})"), + ("SELECT * FROM s NATURAL JOIN sp","s join sp"), + ("SELECT * FROM s CROSS JOIN sp", "(s rename {s# as s#_a1}) join sp"), + ("SELECT * FROM sp INNER JOIN sp USING (\"s#\")", + "(sp rename {p# as p#_a1, qty as qty_a1}) join sp"),-} + ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","sp join s") ] + gfEnv = GraphRefRelationalExprEnv { + gre_context = Just dateExamples, + gre_graph = tgraph, + gre_extra = mempty } + typeF expr = do + let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr) + runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) check (sql, tutd) = do --parse SQL select <- case parse (selectP <* eof) "test" sql of @@ -39,10 +56,11 @@ testSelect = TestCase $ do relExpr <- case parse (relExprP <* eof) "test" tutd of Left err -> error (errorBundlePretty err) Right x -> pure x - selectAsRelExpr <- case convert select of + selectAsRelExpr <- case convert typeF select of Left err -> error (show err) Right x -> pure x - print ("selectAsRelExpr", selectAsRelExpr) + + print ("selectAsRelExpr"::String, selectAsRelExpr) assertEqual (T.unpack sql) relExpr selectAsRelExpr mapM_ check readTests From 5ff637ecf6f027bbaf4709b4cab75e65c9505b40 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 19 Jul 2023 13:47:18 -0400 Subject: [PATCH 006/170] fix faulty logic resulting in empty results for cross joins resolves #361 --- Changelog.markdown | 4 ++++ project-m36.cabal | 2 +- src/lib/ProjectM36/Tuple.hs | 2 +- test/TutorialD/InterpreterTest.hs | 19 ++++++++++++++++++- 4 files changed, 24 insertions(+), 3 deletions(-) diff --git a/Changelog.markdown b/Changelog.markdown index 04057978..fb439381 100644 --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,7 @@ +# 2023-07-18 (v0.9.7) + +* fix critical bug resulting in empty results from cross joins + # 2022-11-05 (v0.9.6) * fix tuple context passed down to extended expressions diff --git a/project-m36.cabal b/project-m36.cabal index d5ba23a2..5fee0aa7 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 0.9.6 +Version: 0.9.7 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple diff --git a/src/lib/ProjectM36/Tuple.hs b/src/lib/ProjectM36/Tuple.hs index 60807fb9..7a286db6 100644 --- a/src/lib/ProjectM36/Tuple.hs +++ b/src/lib/ProjectM36/Tuple.hs @@ -113,7 +113,7 @@ singleTupleSetJoin tup1 tupSet = HS.union -- if there are shared attributes, if they match, create a new tuple from the atoms of both tuples based on the attribute ordering argument singleTupleJoin :: Attributes -> RelationTuple -> RelationTuple -> Either RelationalError (Maybe RelationTuple) singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = if - V.null keysIntersection || atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2 + atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2 then return Nothing else diff --git a/test/TutorialD/InterpreterTest.hs b/test/TutorialD/InterpreterTest.hs index 8567991b..ca096e03 100644 --- a/test/TutorialD/InterpreterTest.hs +++ b/test/TutorialD/InterpreterTest.hs @@ -92,7 +92,8 @@ main = do testExtendProcessorTuplePushdown, testDDLHash, testShowDDL, - testRegisteredQueries + testRegisteredQueries, + testCrossJoin ] simpleRelTests :: Test @@ -847,3 +848,19 @@ testRegisteredQueries = TestCase $ do Right () <- executeDatabaseContextExpr sessionId dbconn (Undefine "x") pure () +testCrossJoin :: Test +testCrossJoin = TestCase $ do + (session, dbconn) <- dateExamplesConnection emptyNotificationCallback + -- Athens, London, Paris cross joined with 17, 12, 14, 19 + executeTutorialD session dbconn "x:=(s{city}) join (s{status})" + eActual <- executeRelationalExpr session dbconn (RelationVariable "x" ()) + let eExpected = mkRelationFromList (attributesFromList [Attribute "city" TextAtomType, Attribute "status" IntegerAtomType]) [[city,status] | city <- map TextAtom ["Athens", "London", "Paris"], status <- map IntegerAtom [30,20,10]] + assertBool "cross join error" (isRight eActual) + assertEqual "cross join" eExpected eActual + + executeTutorialD session dbconn "y:=relation{tuple{a 1},tuple{a 2},tuple{a 3}} join relation{tuple{b 4}, tuple{b 5}, tuple{b 6}}" + let eExpected' = mkRelationFromList (attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" IntegerAtomType]) [[a,b] | a <- map IntegerAtom [1,2,3], b <- map IntegerAtom [4,5,6]] + eActual' <- executeRelationalExpr session dbconn (RelationVariable "y" ()) + assertBool "cross join 2 error" (isRight eActual') + assertEqual "cross join 2" eExpected' eActual' + From db34ecaf9dd9bbb40c72bf61a59aa1cadc5cd9cf Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 19 Jul 2023 14:17:25 -0400 Subject: [PATCH 007/170] fix install-nix-action version --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 1611b815..5cb0c9a9 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -7,7 +7,7 @@ jobs: runs-on: ubuntu-latest steps: - uses: actions/checkout@v3 - - uses: cachix/install-nix-action@v18 + - uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixos-unstable - uses: cachix/cachix-action@v12 From bdd130e1135e7353483d69dcd1713210bc710140 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 20 Jul 2023 23:07:09 -0400 Subject: [PATCH 008/170] remove redundant cabal entry --- project-m36.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/project-m36.cabal b/project-m36.cabal index 5fee0aa7..25aafcb0 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -213,7 +213,6 @@ Executable tutd TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TransGraphRelationalOperator, - TutorialD.Interpreter.SchemaOperator, TutorialD.Printer main-is: TutorialD/tutd.hs CC-Options: -fPIC From 6cd3b92ad17765706b38ab73573f590b128d1277 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 6 Aug 2023 19:17:52 -0400 Subject: [PATCH 009/170] WIP join checkpoint tests pass enable bulk renaming in Rename expression to make expression equality easier to find --- project-m36.cabal | 1 - src/bin/SQL/Interpreter/Convert.hs | 141 ++++++++++++------ src/bin/SQL/Interpreter/Select.hs | 9 +- .../TutorialD/Interpreter/RelationalExpr.hs | 4 +- src/bin/TutorialD/Printer.hs | 7 +- src/lib/ProjectM36/AtomFunctions/Primitive.hs | 2 +- src/lib/ProjectM36/Base.hs | 2 +- src/lib/ProjectM36/HashSecurely.hs | 9 +- src/lib/ProjectM36/IsomorphicSchema.hs | 2 +- src/lib/ProjectM36/Key.hs | 2 +- src/lib/ProjectM36/NormalizeExpr.hs | 4 +- src/lib/ProjectM36/Relation.hs | 5 + src/lib/ProjectM36/RelationalExpression.hs | 14 +- src/lib/ProjectM36/Shortcuts.hs | 3 +- src/lib/ProjectM36/StaticOptimizer.hs | 8 +- .../TransGraphRelationalExpression.hs | 4 +- src/lib/ProjectM36/WithNameExpr.hs | 4 +- test/SQL/InterpreterTest.hs | 9 +- 18 files changed, 148 insertions(+), 82 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index 2eca4b61..461d6f07 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -214,7 +214,6 @@ Executable tutd TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, - TutorialD.Printer, SQL.Interpreter.Base, SQL.Interpreter.Select, SQL.Interpreter.Convert diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index c77a07cd..2a193b26 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -12,14 +12,16 @@ import Data.Text as T (pack,intercalate,Text,concat) import ProjectM36.Relation import Control.Monad (foldM) import qualified Data.Set as S +import qualified Data.Map as M import Data.List (foldl') import qualified Data.Functor.Foldable as Fold import Debug.Trace data SQLError = NotSupportedError T.Text | - TypeMismatch AtomType AtomType | - NoSuchFunction QualifiedName | + TypeMismatchError AtomType AtomType | + NoSuchSQLFunctionError QualifiedName | + DuplicateTableReferenceError QualifiedName | SQLRelationalError RelationalError deriving (Show, Eq) @@ -99,16 +101,24 @@ instance SQLConvert [SelectItem] where -- apply extensions let fExtended = foldl' (\acc ext -> (Extend ext) . acc) id (taskExtenders task) -- apply rename - fRenames <- foldM (\acc (qProjName, (AliasName newName)) -> do + renamesSet <- foldM (\acc (qProjName, (AliasName newName)) -> do oldName <- convert typeF qProjName - pure $ Rename oldName newName . acc) id (taskRenames task) + pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) + let fRenames = if S.null renamesSet then id else Rename renamesSet pure (fExtended . fProjection . fRenames) instance SQLConvert TableExpr where type ConverterF TableExpr = (RelationalExpr, WithNamesAssocs) --does not handle non-relational aspects such as offset, order by, or limit convert typeF tExpr = do - (fromExpr, withExprs) <- convert typeF (fromClause tExpr) + (fromExpr, tableAliasMap) <- convert typeF (fromClause tExpr) + let tableAliasMap' = M.filterWithKey filterRedundantAlias tableAliasMap + filterRedundantAlias (QualifiedName [nam]) (RelationVariable nam' ()) + | nam == nam' = False + filterRedundantAlias _ _ = True + withExprs <- mapM (\(qnam, expr) -> do + nam <- convert typeF qnam + pure (WithNameExpr nam (), expr)) (M.toList tableAliasMap') expr' <- case whereClause tExpr of Just whereExpr -> do restrictPredExpr <- convert typeF whereExpr @@ -121,29 +131,35 @@ instance SQLConvert TableExpr where instance SQLConvert [TableRef] where -- returns base relation expressions plus top-level renames required - type ConverterF [TableRef] = (RelationalExpr, WithNamesAssocs) - convert _ [] = pure (ExistingRelation relationFalse, []) + type ConverterF [TableRef] = (RelationalExpr, TableAliasMap) + convert _ [] = pure (ExistingRelation relationFalse, M.empty) convert typeF (firstRef:trefs) = do --the first table ref must be a straight RelationVariable - (firstRel, withRenames) <- convert typeF firstRef - (expr', withRenames') <- foldM joinTRef (firstRel, withRenames) (zip [1..] trefs) - pure (expr', withRenames') + (firstRel, tableAliases) <- convert typeF firstRef + (expr', tableAliases') <- foldM joinTRef (firstRel, tableAliases) (zip [1..] trefs) + pure (expr', tableAliases') where --TODO: if any of the previous relations have overlap in their attribute names, we must change it to prevent a natural join! - joinTRef (rvA,withRenames) (c,tref) = do - let renamerFolder x expr old_name = - let new_name = T.concat [old_name, "_", x, T.pack (show c)] - in - pure $ Rename old_name new_name expr + joinTRef (rvA,tAliases) (c,tref) = do + let attrRenamer x expr attrs = do + renamed <- mapM (renameOneAttr x expr) attrs + pure (Rename (S.fromList renamed) expr) + renameOneAttr x expr old_name = pure (old_name, new_name) + where + new_name = T.concat [prefix, ".", old_name] + prefix = case expr of + RelationVariable rvName () -> rvName + _ -> x -- probably need to return errors for some expressions + case tref of NaturalJoinTableRef jtref -> do -- then natural join is the only type of join which the relational algebra supports natively - (rvB, withRenames') <- convert typeF jtref - pure $ (Join rvA rvB, withRenames <> withRenames') + (rvB, tAliases') <- convert typeF jtref + pure $ (Join rvA rvB, M.union tAliases tAliases) CrossJoinTableRef jtref -> do --rename all columns to prefix them with a generated alias to prevent any natural join occurring, then perform normal join -- we need the type to get all the attribute names for both relexprs - (rvB, withRenames') <- convert typeF jtref + (rvB, tAliases) <- convert typeF jtref case typeF rvA of Left err -> Left (SQLRelationalError err) Right typeA -> @@ -154,36 +170,51 @@ instance SQLConvert [TableRef] where attrsB = A.attributeNameSet (attributes typeB) attrsIntersection = S.intersection attrsA attrsB --find intersection of attributes and rename all of them with prefix 'expr'+c+'.' - traceShowM ("cross gonk", attrsIntersection) - exprA <- foldM (renamerFolder "a") rvA (S.toList attrsIntersection) - pure (Join exprA rvB, withRenames') + exprA <- attrRenamer "a" rvA (S.toList attrsIntersection) + pure (Join exprA rvB, tAliases) InnerJoinTableRef jtref (JoinUsing qnames) -> do - (rvB, withRenames') <- convert typeF jtref + (rvB, tAliases) <- convert typeF jtref jCondAttrs <- S.fromList <$> mapM (convert typeF) qnames (attrsIntersection, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB - --rename attributes which are not part of the join condition + --rename attributes used in the join condition let attrsToRename = S.difference attrsIntersection jCondAttrs - traceShowM ("inner", attrsToRename, attrsIntersection, jCondAttrs) - exprA <- foldM (renamerFolder "a") rvA (S.toList attrsToRename) - pure (Join exprA rvB, withRenames') - InnerJoinTableRef jtref (JoinOn sexpr) -> do +-- traceShowM ("inner", attrsToRename, attrsIntersection, jCondAttrs) + exprA <- attrRenamer "a" rvA (S.toList attrsToRename) + pure (Join exprA rvB, tAliases) + + InnerJoinTableRef jtref (JoinOn (JoinOnCondition joinExpr)) -> do --create a cross join but extend with the boolean sexpr --extend the table with the join conditions, then join on those --exception: for simple attribute equality, use regular join renames using JoinOn logic - (rvB, withRenames') <- convert typeF jtref + (rvB, tAliases) <- convert typeF jtref + + --rvA and rvB now reference potentially aliased relation variables (needs with clause to execute), but this is useful for making attributes rv-prefixed +-- traceShowM ("converted", rvA, rvB, tAliases) --extract all table aliases to create a remapping for SQL names discovered in the sexpr - (commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB - let sexpr' = renameIdentifier renamer sexpr + (commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB + -- first, execute the rename, renaming all attributes according to their table aliases + let rvPrefix rvExpr = + case rvExpr of + RelationVariable nam () -> pure nam + x -> Left $ NotSupportedError ("cannot derived name for relational expression " <> T.pack (show x)) + rvPrefixA <- rvPrefix rvA + rvPrefixB <- rvPrefix rvB + exprA <- attrRenamer rvPrefixA rvA (S.toList attrsA) + exprB <- attrRenamer rvPrefixB rvB (S.toList attrsB) + -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition + let joinExpr' = renameIdentifier renamer joinExpr renamer n@(QualifiedName [tableAlias,attr]) = --lookup prefixed with table alias - case W.lookup tableAlias withRenames' of - Nothing -> QualifiedName [attr]-- the table was not renamed, but the attribute may have been renamed- how do we know at this point when the sexpr' converter hasn't run yet?! + case M.lookup n tAliases of + -- the table was not renamed, but the attribute may have been renamed + -- find the source of the attribute + Nothing -> n Just found -> error (show (tableAlias, found)) renamer n@(QualifiedName [attr]) = error (show n) - joinRe <- convert typeF sexpr' +-- traceShowM ("joinExpr'", joinExpr') + joinRe <- convert typeF joinExpr' + --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name = --rename all common attrs and use the new names in the join condition - exprA <- foldM (renamerFolder "a") rvA (S.toList commonAttrs) - exprB <- foldM (renamerFolder "b") rvB (S.toList commonAttrs) let allAttrs = S.union attrsA attrsB firstAvailableName c allAttrs' = let new_name = T.pack ("join_" <> show c) in @@ -191,9 +222,14 @@ instance SQLConvert [TableRef] where firstAvailableName (c + 1) allAttrs' else new_name - extender = AttributeExtendTupleExpr (firstAvailableName 1 allAttrs) joinRe - pure (Join (Extend extender exprA) exprB, withRenames') + joinName = firstAvailableName 1 allAttrs + extender = AttributeExtendTupleExpr joinName joinRe + joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) + projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) + pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA))), tAliases) + +--type AttributeNameRemap = M.Map RelVarName AttributeName -- | Used in join condition detection necessary for renames to enable natural joins. commonAttributeNames :: TypeForRelExprF -> RelationalExpr -> RelationalExpr -> Either SQLError (S.Set AttributeName, S.Set AttributeName, S.Set AttributeName) @@ -208,25 +244,34 @@ commonAttributeNames typeF rvA rvB = attrsB = A.attributeNameSet (attributes typeB) pure $ (S.intersection attrsA attrsB, attrsA, attrsB) - +--over the course of conversion, we collect all the table aliases we encounter, including non-aliased table references +type TableAliasMap = M.Map QualifiedName RelationalExpr + +insertTableAlias :: QualifiedName -> RelationalExpr -> TableAliasMap -> Either SQLError TableAliasMap +insertTableAlias qn expr map' = + case M.lookup qn map' of + Nothing -> pure $ M.insert qn expr map' + Just _ -> Left (DuplicateTableReferenceError qn) + -- convert a TableRef in isolation- to be used with the first TableRef only instance SQLConvert TableRef where -- return base relation variable expression plus a function to apply top-level rv renames using WithNameExpr - type ConverterF TableRef = (RelationalExpr, WithNamesAssocs) + type ConverterF TableRef = (RelationalExpr, TableAliasMap) --SELECT x FROM a,_b_ creates a cross join - convert _ (SimpleTableRef (QualifiedName [nam])) = - pure (RelationVariable nam (), []) + convert _ (SimpleTableRef qn@(QualifiedName [nam])) = do + let rv = RelationVariable nam () + pure (rv, M.singleton qn rv) -- include with clause even for simple cases because we use this mapping to convert typeF (AliasedTableRef tnam (AliasName newName)) = do - (rv, withNames) <- convert typeF tnam - pure $ (RelationVariable newName (), (WithNameExpr newName (), rv):withNames) + (rv, _) <- convert typeF tnam + pure $ (RelationVariable newName (), M.singleton (QualifiedName [newName]) rv) convert _ x = Left $ NotSupportedError (T.pack (show x)) instance SQLConvert RestrictionExpr where type ConverterF RestrictionExpr = RestrictionPredicateExpr convert typeF (RestrictionExpr rexpr) = do - let wrongType t = Left $ TypeMismatch t BoolAtomType --must be boolean expression + let wrongType t = Left $ TypeMismatchError t BoolAtomType --must be boolean expression attrName' (QualifiedName ts) = T.intercalate "." ts case rexpr of IntegerLiteral{} -> wrongType IntegerAtomType @@ -247,7 +292,7 @@ lookupFunc qname = case qname of QualifiedName [nam] -> case lookup nam sqlFuncs of - Nothing -> Left $ NoSuchFunction qname + Nothing -> Left $ NoSuchSQLFunctionError qname Just match -> pure match where f n args = FunctionAtomExpr n args () @@ -276,6 +321,12 @@ instance SQLConvert ScalarExpr where f <- lookupFunc qn pure $ f [a,b] +instance SQLConvert JoinOnCondition where + type ConverterF JoinOnCondition = (RelationalExpr -> RelationalExpr) + convert typeF (JoinOnCondition expr) = do + case expr of + Identifier (QualifiedName [tAlias, colName]) -> undefined + instance SQLConvert ProjectionScalarExpr where type ConverterF ProjectionScalarExpr = AtomExpr convert typeF expr = do diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 98dd5f96..ae115ffe 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -85,7 +85,10 @@ data NullsOrder = NullsFirst | NullsLast data JoinType = InnerJoin | RightOuterJoin | LeftOuterJoin | FullOuterJoin | CrossJoin | NaturalJoin deriving (Show, Eq) -data JoinCondition = JoinOn ScalarExpr | JoinUsing [UnqualifiedName] +data JoinCondition = JoinOn JoinOnCondition | JoinUsing [UnqualifiedName] + deriving (Show, Eq) + +newtype JoinOnCondition = JoinOnCondition ScalarExpr deriving (Show, Eq) data Alias = Alias QualifiedName (Maybe AliasName) @@ -98,7 +101,7 @@ data ProjectionName = ProjectionName Text | Asterisk deriving (Show, Eq, Ord) data QualifiedName = QualifiedName [Text] - deriving (Show, Eq) + deriving (Show, Eq, Ord) data UnqualifiedName = UnqualifiedName Text deriving (Show, Eq) @@ -165,7 +168,7 @@ fromP = reserved "from" *> ((:) <$> nonJoinTref <*> sepByComma joinP) joinConditionP :: Parser JoinCondition joinConditionP = do - (JoinOn <$> (reserved "on" *> scalarExprP)) <|> + (JoinOn <$> (reserved "on" *> (JoinOnCondition <$> scalarExprP))) <|> JoinUsing <$> (reserved "using" *> parens (sepBy1 unqualifiedNameP comma)) joinTypeP :: Parser JoinType diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs index 37b84e25..890a0d88 100644 --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -82,9 +82,9 @@ renameP = do reservedOp "rename" renameList <- braces (sepBy renameClauseP comma) case renameList of - [] -> pure (Restrict TruePredicate) --no-op when rename list is empty + [] -> pure id renames -> - pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames + pure $ Rename (S.fromList renames) whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) whereClauseP = reservedOp "where" *> (Restrict <$> restrictionPredicateP) diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index dd391ca5..d5f6d6aa 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -85,7 +85,7 @@ instance Pretty RelationalExpr where pretty (MakeStaticRelation attrs tupSet) = "relation" <> prettyBracesList (A.toList attrs) <> prettyBracesList (asList tupSet) pretty (Union a b) = parens $ pretty' a <+> "union" <+> pretty' b pretty (Join a b) = parens $ pretty' a <+> "join" <+> pretty' b - pretty (Rename n1 n2 relExpr) = parens $ pretty relExpr <+> "rename" <+> braces (pretty n1 <+> "as" <+> pretty n2) + pretty (Rename attrs relExpr) = parens $ pretty relExpr <+> "rename" <+> prettyBracesList (map RenameTuple (S.toList attrs)) pretty (Difference a b) = parens $ pretty' a <+> "minus" <+> pretty' b pretty (Group attrNames attrName relExpr) = parens $ pretty relExpr <+> "group" <+> parens (pretty attrNames <+> "as" <+> pretty attrName) pretty (Ungroup attrName relExpr) = parens $ pretty' relExpr <+> "ungroup" <+> pretty attrName @@ -146,6 +146,11 @@ instance Pretty AtomType where instance Pretty ExtendTupleExpr where pretty (AttributeExtendTupleExpr attrName atomExpr) = pretty attrName <> ":=" <> pretty atomExpr +newtype RenameTuple = RenameTuple { _unRenameTuple :: (AttributeName, AttributeName) } + +instance Pretty RenameTuple where + pretty (RenameTuple (n1, n2)) = pretty n1 <+> "as" <+> pretty n2 + instance Pretty RestrictionPredicateExpr where pretty TruePredicate = "true" diff --git a/src/lib/ProjectM36/AtomFunctions/Primitive.hs b/src/lib/ProjectM36/AtomFunctions/Primitive.hs index 5350c549..9252a339 100644 --- a/src/lib/ProjectM36/AtomFunctions/Primitive.hs +++ b/src/lib/ProjectM36/AtomFunctions/Primitive.hs @@ -43,7 +43,7 @@ primitiveAtomFunctions = HS.fromList [ funcBody = body $ relationAtomFunc relationMin }, Function { funcName = "eq", - funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType], + funcType = [TypeVariableType "a", TypeVariableType "a", BoolAtomType], funcBody = body $ \case [i1,i2] -> pure (BoolAtom (i1 == i2)) _ -> Left AtomFunctionTypeMismatchError diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 219cacaf..c57922e6 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -233,7 +233,7 @@ data RelationalExprBase a = --- | Create a join of two relational expressions. The join occurs on attributes which are identical. If the expressions have no overlapping attributes, the join becomes a cross-product of both tuple sets. Join (RelationalExprBase a) (RelationalExprBase a) | --- | Rename an attribute (first argument) to another (second argument). - Rename AttributeName AttributeName (RelationalExprBase a) | + Rename (S.Set (AttributeName, AttributeName)) (RelationalExprBase a) | --- | Return a relation containing all tuples of the first argument which do not appear in the second argument (minus). Difference (RelationalExprBase a) (RelationalExprBase a) | --- | Create a sub-relation composed of the first argument's attributes which will become an attribute of the result expression. The unreferenced attributes are not altered in the result but duplicate tuples in the projection of the expression minus the attribute names are compressed into one. For more information, diff --git a/src/lib/ProjectM36/HashSecurely.hs b/src/lib/ProjectM36/HashSecurely.hs index 78ef62ad..2ca45b9e 100644 --- a/src/lib/ProjectM36/HashSecurely.hs +++ b/src/lib/ProjectM36/HashSecurely.hs @@ -25,7 +25,6 @@ import qualified Data.Set as S import Data.Time.Calendar import Data.Time.Clock import Codec.Winery (Serialise) -import Data.Int (Int64) newtype SecureHash = SecureHash { _unSecureHash :: B.ByteString } deriving (Serialise, Show, Eq) @@ -86,8 +85,8 @@ instance HashBytes a => HashBytes (RelationalExprBase a) where hashBytesL ctx "Union" [SHash exprA, SHash exprB] hashBytes (Join exprA exprB) ctx = hashBytesL ctx "Join" [SHash exprA, SHash exprB] - hashBytes (Rename nameA nameB expr) ctx = - hashBytesL ctx "Rename" [SHash nameA, SHash nameB, SHash expr] + hashBytes (Rename attrs expr) ctx = + hashBytesL ctx "Rename" [SHash attrs, SHash expr] hashBytes (Difference exprA exprB) ctx = hashBytesL ctx "Difference" [SHash exprA, SHash exprB] hashBytes (Group names name expr) ctx = @@ -116,6 +115,10 @@ instance HashBytes a => HashBytes (ExtendTupleExprBase a) where hashBytes (AttributeExtendTupleExpr name expr) ctx = hashBytesL ctx "AttributeExtendTupleExpr" [SHash name, SHash expr] +instance HashBytes (S.Set (AttributeName, AttributeName)) where + hashBytes attrs ctx = + hashBytesL ctx "RenameAttrSet" (V.concatMap (\(a,b) -> V.fromList [SHash a, SHash b]) (V.fromList $ S.toList attrs)) + instance HashBytes a => HashBytes (WithNameExprBase a) where hashBytes (WithNameExpr rv marker) ctx = hashBytesL ctx "WithNameExpr" [SHash rv, SHash marker] diff --git a/src/lib/ProjectM36/IsomorphicSchema.hs b/src/lib/ProjectM36/IsomorphicSchema.hs index cf2db2f3..a59fb20e 100644 --- a/src/lib/ProjectM36/IsomorphicSchema.hs +++ b/src/lib/ProjectM36/IsomorphicSchema.hs @@ -163,7 +163,7 @@ relExprMogrify func (Join exprA exprB) = do exA <- func exprA exB <- func exprB func (Join exA exB) -relExprMogrify func (Rename n1 n2 expr) = func expr >>= \ex -> func (Rename n1 n2 ex) +relExprMogrify func (Rename attrs expr) = func expr >>= \ex -> func (Rename attrs ex) relExprMogrify func (Difference exprA exprB) = do exA <- func exprA exB <- func exprB diff --git a/src/lib/ProjectM36/Key.hs b/src/lib/ProjectM36/Key.hs index d6dfbfbb..455c09ca 100644 --- a/src/lib/ProjectM36/Key.hs +++ b/src/lib/ProjectM36/Key.hs @@ -56,7 +56,7 @@ inclusionDependencyForForeignKey (rvA, attrsA) (rvB, attrsB) = folder (attrExpected, attrExisting) expr = if attrExpected == attrExisting then expr else - Rename attrExisting attrExpected expr + Rename (S.singleton (attrExisting, attrExpected)) expr -- if the constraint is a foreign key constraint, then return the relations and attributes involved - this only detects foreign keys created with `databaseContextExprForForeignKey` isForeignKeyFor :: InclusionDependency -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> Bool diff --git a/src/lib/ProjectM36/NormalizeExpr.hs b/src/lib/ProjectM36/NormalizeExpr.hs index bf9e6d01..8b646a4c 100644 --- a/src/lib/ProjectM36/NormalizeExpr.hs +++ b/src/lib/ProjectM36/NormalizeExpr.hs @@ -29,8 +29,8 @@ processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> askMark processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB -processRelationalExpr (Rename attrA attrB expr) = - Rename attrA attrB <$> processRelationalExpr expr +processRelationalExpr (Rename attrs expr) = + Rename attrs <$> processRelationalExpr expr processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr diff --git a/src/lib/ProjectM36/Relation.hs b/src/lib/ProjectM36/Relation.hs index 58257fb5..14ba69f1 100644 --- a/src/lib/ProjectM36/Relation.hs +++ b/src/lib/ProjectM36/Relation.hs @@ -94,6 +94,11 @@ project attrNames rel@(Relation _ tupSet) = do newTupleList <- mapM (tupleProject newAttrs) (asList tupSet) pure (Relation newAttrs (RelationTupleSet (HS.toList (HS.fromList newTupleList)))) +renameMany :: S.Set (AttributeName, AttributeName) -> Relation -> Either RelationalError Relation +renameMany renames rel = foldM folder rel (S.toList renames) + where + folder r (oldName, newName) = rename oldName newName r + rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) | not attributeValid = Left $ AttributeNamesMismatchError (S.singleton oldAttrName) diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index 48be18d1..30650b02 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -335,7 +335,7 @@ evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do else tmpAttrName updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr) - projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr) + projectAndRename attr expr = Rename (S.singleton ((tmpAttr attr), attr)) (Project (InvertedAttributeNames (S.singleton attr)) expr) restrictedPortion = Restrict pred' rvExpr updated = foldr (\(oldname, atomExpr) accum -> let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in @@ -1111,9 +1111,9 @@ evalGraphRefRelationalExpr (Join exprA exprB) = do relA <- evalGraphRefRelationalExpr exprA relB <- evalGraphRefRelationalExpr exprB lift $ except $ join relA relB -evalGraphRefRelationalExpr (Rename oldName newName expr) = do +evalGraphRefRelationalExpr (Rename attrsSet expr) = do rel <- evalGraphRefRelationalExpr expr - lift $ except $ rename oldName newName rel + lift $ except $ renameMany attrsSet rel evalGraphRefRelationalExpr (Difference exprA exprB) = do relA <- evalGraphRefRelationalExpr exprA relB <- evalGraphRefRelationalExpr exprB @@ -1196,9 +1196,9 @@ typeForGraphRefRelationalExpr (Join exprA exprB) = do exprA' <- typeForGraphRefRelationalExpr exprA exprB' <- typeForGraphRefRelationalExpr exprB lift $ except $ join exprA' exprB' -typeForGraphRefRelationalExpr (Rename oldAttr newAttr expr) = do +typeForGraphRefRelationalExpr (Rename attrs expr) = do expr' <- typeForGraphRefRelationalExpr expr - lift $ except $ rename oldAttr newAttr expr' + lift $ except $ renameMany attrs expr' typeForGraphRefRelationalExpr (Difference exprA exprB) = do exprA' <- typeForGraphRefRelationalExpr exprA exprB' <- typeForGraphRefRelationalExpr exprB @@ -1283,7 +1283,7 @@ mkEmptyRelVars = M.map mkEmptyRelVar mkEmptyRelVar (Project attrNames expr) = Project attrNames (mkEmptyRelVar expr) mkEmptyRelVar (Union exprA exprB) = Union (mkEmptyRelVar exprA) (mkEmptyRelVar exprB) mkEmptyRelVar (Join exprA exprB) = Join (mkEmptyRelVar exprA) (mkEmptyRelVar exprB) - mkEmptyRelVar (Rename nameA nameB expr) = Rename nameA nameB (mkEmptyRelVar expr) + mkEmptyRelVar (Rename attrs expr) = Rename attrs (mkEmptyRelVar expr) mkEmptyRelVar (Difference exprA exprB) = Difference (mkEmptyRelVar exprA) (mkEmptyRelVar exprB) mkEmptyRelVar (Group attrNames attrName expr) = Group attrNames attrName (mkEmptyRelVar expr) mkEmptyRelVar (Ungroup attrName expr) = Ungroup attrName (mkEmptyRelVar expr) @@ -1363,7 +1363,7 @@ instance ResolveGraphRefTransactionMarker GraphRefRelationalExpr where resolve (Project attrNames relExpr) = Project <$> resolve attrNames <*> resolve relExpr resolve (Union exprA exprB) = Union <$> resolve exprA <*> resolve exprB resolve (Join exprA exprB) = Join <$> resolve exprA <*> resolve exprB - resolve (Rename attrA attrB expr) = Rename attrA attrB <$> resolve expr + resolve (Rename attrs expr) = Rename attrs <$> resolve expr resolve (Difference exprA exprB) = Difference <$> resolve exprA <*> resolve exprB resolve (Group namesA nameB expr) = Group <$> resolve namesA <*> pure nameB <*> resolve expr resolve (Ungroup nameA expr) = Ungroup nameA <$> resolve expr diff --git a/src/lib/ProjectM36/Shortcuts.hs b/src/lib/ProjectM36/Shortcuts.hs index 4b22d9c3..048bad64 100644 --- a/src/lib/ProjectM36/Shortcuts.hs +++ b/src/lib/ProjectM36/Shortcuts.hs @@ -118,8 +118,7 @@ tuple as' = TupleExpr (M.fromList as') rename :: RelationalExpr -> [(AttributeName,AttributeName)] -> RelationalExpr rename relExpr renameList = case renameList of [] -> Restrict TruePredicate relExpr - renames -> - foldl (\acc (old,new) -> Rename old new acc) relExpr renames + renames -> Rename (S.fromList renames) relExpr --project !! -- #a !! [#b,#c] diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index 43b1be9b..569bd026 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -506,8 +506,8 @@ applyStaticRestrictionCollapse expr = Union (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2) Join sub1 sub2 -> Join (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2) - Rename n1 n2 sub -> - Rename n1 n2 (applyStaticRestrictionCollapse sub) + Rename attrs sub -> + Rename attrs (applyStaticRestrictionCollapse sub) Difference sub1 sub2 -> Difference (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2) Group n1 n2 sub -> @@ -561,8 +561,8 @@ applyStaticRestrictionPushdown expr = case expr of Union (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2) Join sub1 sub2 -> Join (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2) - Rename n1 n2 sub -> - Rename n1 n2 (applyStaticRestrictionPushdown sub) + Rename attrs sub -> + Rename attrs (applyStaticRestrictionPushdown sub) Difference sub1 sub2 -> Difference (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2) Group n1 n2 sub -> diff --git a/src/lib/ProjectM36/TransGraphRelationalExpression.hs b/src/lib/ProjectM36/TransGraphRelationalExpression.hs index d81882ba..e9ad5794 100644 --- a/src/lib/ProjectM36/TransGraphRelationalExpression.hs +++ b/src/lib/ProjectM36/TransGraphRelationalExpression.hs @@ -72,8 +72,8 @@ processTransGraphRelationalExpr (Union exprA exprB) = Union <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB processTransGraphRelationalExpr (Join exprA exprB) = Join <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB -processTransGraphRelationalExpr (Rename attrName1 attrName2 expr) = - Rename attrName1 attrName2 <$> processTransGraphRelationalExpr expr +processTransGraphRelationalExpr (Rename attrs expr) = + Rename attrs <$> processTransGraphRelationalExpr expr processTransGraphRelationalExpr (Difference exprA exprB) = Difference <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB processTransGraphRelationalExpr (Group transAttrNames attrName expr) = diff --git a/src/lib/ProjectM36/WithNameExpr.hs b/src/lib/ProjectM36/WithNameExpr.hs index 622a9e6a..b8127d05 100644 --- a/src/lib/ProjectM36/WithNameExpr.hs +++ b/src/lib/ProjectM36/WithNameExpr.hs @@ -31,8 +31,8 @@ substituteWithNameMacros macros (Union exprA exprB) = Union (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB) substituteWithNameMacros macros (Join exprA exprB) = Join (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB) -substituteWithNameMacros macros (Rename attrA attrB expr) = - Rename attrA attrB (substituteWithNameMacros macros expr) +substituteWithNameMacros macros (Rename attrs expr) = + Rename attrs (substituteWithNameMacros macros expr) substituteWithNameMacros macros (Difference exprA exprB) = Difference (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB) substituteWithNameMacros macros (Group attrs attr expr) = diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 0dbbd925..36b02534 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -24,7 +24,7 @@ testSelect = TestCase $ do -- check that SQL and tutd compile to same thing (tgraph,transId) <- freshTransactionGraph dateExamples let p tin = parse selectP "test" tin - readTests = [{-("SELECT * FROM test", "test"), + readTests = [("SELECT * FROM test", "test"), ("SELECT a FROM test", "test{a}"), ("SELECT a FROM test where b=3","(test where b=3){a}"), ("SELECT a,b FROM test where b>3","(test where gt(@b,3)){a,b}"), @@ -35,10 +35,11 @@ testSelect = TestCase $ do ("SELECT sup.city,sup.sname FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`})"), ("SELECT sup.* FROM s as sup","with (sup as s) (sup{all from sup})"), ("SELECT * FROM s NATURAL JOIN sp","s join sp"), - ("SELECT * FROM s CROSS JOIN sp", "(s rename {s# as s#_a1}) join sp"), + ("SELECT * FROM s CROSS JOIN sp", "(s rename {s# as `s.s#`}) join sp"), ("SELECT * FROM sp INNER JOIN sp USING (\"s#\")", - "(sp rename {p# as p#_a1, qty as qty_a1}) join sp"),-} - ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","sp join s") + "(sp rename {p# as `sp.p#`, qty as `sp.qty`}) join sp"), + + ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1}") ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, From 32ba28598fdb987299c4fb1965e441d896afcc4e Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 6 Aug 2023 23:47:55 -0400 Subject: [PATCH 010/170] WIP joins with aliasing working --- src/bin/SQL/Interpreter/Convert.hs | 40 +++++++++++++++++++----------- src/lib/ProjectM36/Base.hs | 2 +- test/SQL/InterpreterTest.hs | 11 +++++--- 3 files changed, 35 insertions(+), 18 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 2a193b26..90aecc52 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -44,6 +44,16 @@ instance SQLConvert Select where _ -> With withNames pure (withF (projF rvExpr)) +tableAliasesAsWithNameAssocs :: TableAliasMap -> Either SQLError WithNamesAssocs +tableAliasesAsWithNameAssocs tmap = + filter notSelfRef <$> mapM mapper (M.toList tmap) + where + notSelfRef (WithNameExpr nam (), RelationVariable nam' ()) | nam == nam' = False + | otherwise = True + notSelfRef _ = True + mapper (QualifiedName [nam], rvExpr) = pure (WithNameExpr nam (), rvExpr) + mapper (qn, _) = Left (NotSupportedError ("schema qualified table names: " <> T.pack (show qn))) + data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set QualifiedProjectionName, taskRenames :: [(QualifiedProjectionName, AliasName)], taskExtenders :: [ExtendTupleExpr] @@ -140,7 +150,7 @@ instance SQLConvert [TableRef] where pure (expr', tableAliases') where --TODO: if any of the previous relations have overlap in their attribute names, we must change it to prevent a natural join! - joinTRef (rvA,tAliases) (c,tref) = do + joinTRef (rvA,tAliasesA) (c,tref) = do let attrRenamer x expr attrs = do renamed <- mapM (renameOneAttr x expr) attrs pure (Rename (S.fromList renamed) expr) @@ -154,12 +164,12 @@ instance SQLConvert [TableRef] where case tref of NaturalJoinTableRef jtref -> do -- then natural join is the only type of join which the relational algebra supports natively - (rvB, tAliases') <- convert typeF jtref - pure $ (Join rvA rvB, M.union tAliases tAliases) + (rvB, tAliasesB) <- convert typeF jtref + pure $ (Join rvA rvB, M.union tAliasesA tAliasesB) CrossJoinTableRef jtref -> do --rename all columns to prefix them with a generated alias to prevent any natural join occurring, then perform normal join -- we need the type to get all the attribute names for both relexprs - (rvB, tAliases) <- convert typeF jtref + (rvB, tAliasesB) <- convert typeF jtref case typeF rvA of Left err -> Left (SQLRelationalError err) Right typeA -> @@ -171,27 +181,29 @@ instance SQLConvert [TableRef] where attrsIntersection = S.intersection attrsA attrsB --find intersection of attributes and rename all of them with prefix 'expr'+c+'.' exprA <- attrRenamer "a" rvA (S.toList attrsIntersection) - pure (Join exprA rvB, tAliases) + pure (Join exprA rvB, M.union tAliasesA tAliasesB) InnerJoinTableRef jtref (JoinUsing qnames) -> do - (rvB, tAliases) <- convert typeF jtref + (rvB, tAliasesB) <- convert typeF jtref jCondAttrs <- S.fromList <$> mapM (convert typeF) qnames (attrsIntersection, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB --rename attributes used in the join condition let attrsToRename = S.difference attrsIntersection jCondAttrs -- traceShowM ("inner", attrsToRename, attrsIntersection, jCondAttrs) exprA <- attrRenamer "a" rvA (S.toList attrsToRename) - pure (Join exprA rvB, tAliases) + pure (Join exprA rvB, M.union tAliasesA tAliasesB) InnerJoinTableRef jtref (JoinOn (JoinOnCondition joinExpr)) -> do --create a cross join but extend with the boolean sexpr --extend the table with the join conditions, then join on those --exception: for simple attribute equality, use regular join renames using JoinOn logic - (rvB, tAliases) <- convert typeF jtref - + + (rvB, tAliasesB) <- convert typeF jtref --rvA and rvB now reference potentially aliased relation variables (needs with clause to execute), but this is useful for making attributes rv-prefixed -- traceShowM ("converted", rvA, rvB, tAliases) --extract all table aliases to create a remapping for SQL names discovered in the sexpr - (commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB + let allAliases = M.union tAliasesA tAliasesB + withExpr <- With <$> tableAliasesAsWithNameAssocs allAliases + (commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF (withExpr rvA) (withExpr rvB) -- first, execute the rename, renaming all attributes according to their table aliases let rvPrefix rvExpr = case rvExpr of @@ -204,15 +216,15 @@ instance SQLConvert [TableRef] where -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition let joinExpr' = renameIdentifier renamer joinExpr renamer n@(QualifiedName [tableAlias,attr]) = --lookup prefixed with table alias - case M.lookup n tAliases of + case M.lookup n allAliases of -- the table was not renamed, but the attribute may have been renamed -- find the source of the attribute Nothing -> n Just found -> error (show (tableAlias, found)) renamer n@(QualifiedName [attr]) = error (show n) --- traceShowM ("joinExpr'", joinExpr') + traceShowM ("joinExpr'", joinExpr') joinRe <- convert typeF joinExpr' - + traceShowM ("joinRe", joinRe) --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name = --rename all common attrs and use the new names in the join condition let allAttrs = S.union attrsA attrsB @@ -226,7 +238,7 @@ instance SQLConvert [TableRef] where extender = AttributeExtendTupleExpr joinName joinRe joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) - pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA))), tAliases) + pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA))), allAliases) --type AttributeNameRemap = M.Map RelVarName AttributeName diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index c57922e6..24c808eb 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -248,7 +248,7 @@ data RelationalExprBase a = Extend (ExtendTupleExprBase a) (RelationalExprBase a) | --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend --Evaluate relationalExpr with scoped views - With [(WithNameExprBase a, RelationalExprBase a)] (RelationalExprBase a) + With (WithNamesAssocsBase a) (RelationalExprBase a) deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable) instance Hashable RelationalExpr diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 36b02534..8e773540 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -39,7 +39,9 @@ testSelect = TestCase $ do ("SELECT * FROM sp INNER JOIN sp USING (\"s#\")", "(sp rename {p# as `sp.p#`, qty as `sp.qty`}) join sp"), - ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1}") + ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1}"), + ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#", + "with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1}") ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, @@ -49,10 +51,13 @@ testSelect = TestCase $ do let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr) runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) check (sql, tutd) = do + print sql --parse SQL select <- case parse (selectP <* eof) "test" sql of Left err -> error (errorBundlePretty err) - Right x -> print x >> pure x + Right x -> do + --print x + pure x --parse tutd relExpr <- case parse (relExprP <* eof) "test" tutd of Left err -> error (errorBundlePretty err) @@ -61,7 +66,7 @@ testSelect = TestCase $ do Left err -> error (show err) Right x -> pure x - print ("selectAsRelExpr"::String, selectAsRelExpr) + --print ("selectAsRelExpr"::String, selectAsRelExpr) assertEqual (T.unpack sql) relExpr selectAsRelExpr mapM_ check readTests From 1736f031ee1a49729adb02c5f328eeef87c7cf62 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 7 Aug 2023 11:11:59 -0400 Subject: [PATCH 011/170] WIP formula extension test --- src/bin/SQL/Interpreter/Convert.hs | 12 +++++-- test/SQL/InterpreterTest.hs | 52 +++++++++++++++++++----------- 2 files changed, 43 insertions(+), 21 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 90aecc52..b3f171d9 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -93,7 +93,12 @@ instance SQLConvert [SelectItem] where selItemFolder acc (c, (scalarExpr, mAlias)) = do atomExpr <- convert typeF scalarExpr - pure $ acc { taskExtenders = AttributeExtendTupleExpr (attrName' mAlias c) atomExpr : taskExtenders acc } + let newAttrName = attrName' mAlias c + -- we need to apply the projections after the extension! + pure $ acc { taskExtenders = AttributeExtendTupleExpr newAttrName atomExpr : taskExtenders acc, + taskProjections = S.insert (QualifiedProjectionName [ProjectionName newAttrName]) (taskProjections acc) + } + traceShowM ("selItems", selItems) task <- foldM selItemFolder emptyTask (zip [1::Int ..] selItems) --apply projections fProjection <- if S.null (taskProjections task) then @@ -115,7 +120,7 @@ instance SQLConvert [SelectItem] where oldName <- convert typeF qProjName pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) let fRenames = if S.null renamesSet then id else Rename renamesSet - pure (fExtended . fProjection . fRenames) + pure (fProjection . fExtended . fRenames) instance SQLConvert TableExpr where type ConverterF TableExpr = (RelationalExpr, WithNamesAssocs) @@ -314,7 +319,8 @@ lookupFunc qname = ("<=",f "lte"), ("=",f "eq"), ("!=",f "not_eq"), -- function missing - ("<>",f "not_eq") -- function missing + ("<>",f "not_eq"), -- function missing + ("+", f "add") ] instance SQLConvert ScalarExpr where diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 8e773540..0ffecdee 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -24,24 +24,40 @@ testSelect = TestCase $ do -- check that SQL and tutd compile to same thing (tgraph,transId) <- freshTransactionGraph dateExamples let p tin = parse selectP "test" tin - readTests = [("SELECT * FROM test", "test"), - ("SELECT a FROM test", "test{a}"), - ("SELECT a FROM test where b=3","(test where b=3){a}"), - ("SELECT a,b FROM test where b>3","(test where gt(@b,3)){a,b}"), - ("SELECT a,b,10 FROM test","test{a,b}:{attr_3:=10}"), - ("SELECT a AS x FROM test","(test rename {a as x}){x}"), - ("sElECt A aS X FRoM TeST","(test rename {a as x}){x}"), - ("SELECT sup.city FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`})"), - ("SELECT sup.city,sup.sname FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`})"), - ("SELECT sup.* FROM s as sup","with (sup as s) (sup{all from sup})"), - ("SELECT * FROM s NATURAL JOIN sp","s join sp"), - ("SELECT * FROM s CROSS JOIN sp", "(s rename {s# as `s.s#`}) join sp"), - ("SELECT * FROM sp INNER JOIN sp USING (\"s#\")", - "(sp rename {p# as `sp.p#`, qty as `sp.qty`}) join sp"), - - ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1}"), - ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#", - "with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1}") + readTests = [ + -- simple relvar + ("SELECT * FROM test", "test"), + -- simple projection + ("SELECT a FROM test", "test{a}"), + -- restriction + ("SELECT a FROM test where b=3","(test where b=3){a}"), + -- restriction + ("SELECT a,b FROM test where b>3","(test where gt(@b,3)){a,b}"), + -- extension mixed with projection + ("SELECT a,b,10 FROM test","(test:{attr_3:=10}){a,b,attr_3}"), + -- column alias + ("SELECT a AS x FROM test","(test rename {a as x}){x}"), + -- case insensitivity + ("sElECt A aS X FRoM TeST","(test rename {a as x}){x}"), + --column from aliased table + ("SELECT sup.city FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`})"), + --projection with alias + ("SELECT sup.city,sup.sname FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`})"), + ("SELECT sup.* FROM s as sup","with (sup as s) (sup{all from sup})"), + -- natural join + ("SELECT * FROM s NATURAL JOIN sp","s join sp"), + -- cross join + ("SELECT * FROM s CROSS JOIN sp", "(s rename {s# as `s.s#`}) join sp"), + -- unaliased join using + ("SELECT * FROM sp INNER JOIN sp USING (\"s#\")", + "(sp rename {p# as `sp.p#`, qty as `sp.qty`}) join sp"), + -- unaliased join + ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1}"), + -- aliased join on + ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#", + "with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1}"), + -- formula extension + ("SELECT status+10 FROM s", "(s : {attr_1:=add(@status,10)}) { attr_1 }") ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, From e0cd33366bf230098553bbf8ff75eb12a3badd46 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 8 Aug 2023 00:38:47 -0400 Subject: [PATCH 012/170] WIP add support for boolean expressions in join conditions add support for TABLE --- src/bin/SQL/Interpreter/Convert.hs | 4 ++- src/bin/SQL/Interpreter/Select.hs | 30 ++++++++++++++++++- src/lib/ProjectM36/AtomFunctions/Primitive.hs | 13 ++++++++ test/SQL/InterpreterTest.hs | 21 +++++++++++-- 4 files changed, 63 insertions(+), 5 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index b3f171d9..e6acf92d 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -320,7 +320,9 @@ lookupFunc qname = ("=",f "eq"), ("!=",f "not_eq"), -- function missing ("<>",f "not_eq"), -- function missing - ("+", f "add") + ("+", f "add"), + ("and", f "and"), + ("or", f "or") ] instance SQLConvert ScalarExpr where diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index ae115ffe..67cdf8d9 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -16,6 +16,11 @@ data Select = Select { distinctness :: Maybe Distinctness, } deriving (Show, Eq) +emptySelect :: Select +emptySelect = Select { distinctness = Nothing, + projectionClause = [], + tableExpr = Nothing } + data InFlag = In | NotIn deriving (Show, Eq) @@ -62,8 +67,12 @@ data ScalarExprBase n = -- | ExistsSubQuery Select -- | UniqueSubQuery Select -- | ScalarSubQuery Select + | BooleanOperatorExpr (ScalarExprBase n) BoolOp (ScalarExprBase n) deriving (Show, Eq) +data BoolOp = AndOp | OrOp + deriving (Eq, Show) + data InPredicateValue = InList [ScalarExpr] | InQueryExpr Select | InScalarExpr ScalarExpr deriving (Eq, Show) @@ -110,7 +119,16 @@ newtype AliasName = AliasName Text deriving (Show, Eq) data Distinctness = Distinct | All deriving (Show, Eq) - + +queryExprP :: Parser Select +queryExprP = tableP <|> selectP + +tableP :: Parser Select +tableP = do + reserved "table" + tname <- qualifiedNameP + pure $ emptySelect { tableExpr = Just $ emptyTableExpr { fromClause = [SimpleTableRef tname] } } + selectP :: Parser Select selectP = do reserved "select" @@ -144,6 +162,15 @@ data TableExpr = } deriving (Show, Eq) +emptyTableExpr :: TableExpr +emptyTableExpr = TableExpr { fromClause = [], + whereClause = Nothing, + groupByClause = [], + havingClause = Nothing, + orderByClause = [], + limitClause = Nothing, + offsetClause = Nothing } + tableExprP :: Parser TableExpr tableExprP = TableExpr <$> fromP <*> optional whereP <*> option [] groupByP <*> optional havingP <*> option [] orderByP <*> limitP <*> offsetP @@ -232,6 +259,7 @@ scalarExprOp = map binarySymbolN ["<",">",">=","<=","!=","<>","="], {- [binarySymbolsN ["is", "distinct", "from"], binarySymbolsN ["is", "not", "distinct", "from"]],-} + [binarySymbolL "and"], [prefixSymbol "not"], [binarySymbolL "or"] -- AT TIME ZONE diff --git a/src/lib/ProjectM36/AtomFunctions/Primitive.hs b/src/lib/ProjectM36/AtomFunctions/Primitive.hs index 9252a339..9fc38c98 100644 --- a/src/lib/ProjectM36/AtomFunctions/Primitive.hs +++ b/src/lib/ProjectM36/AtomFunctions/Primitive.hs @@ -92,7 +92,20 @@ primitiveAtomFunctions = HS.fromList [ Just u -> pure $ UUIDAtom u Nothing -> Left $ InvalidUUIDString v _ -> Left AtomFunctionTypeMismatchError + }, + Function { funcName = "and", + funcType = [BoolAtomType, BoolAtomType, BoolAtomType], + funcBody = body $ \case + [BoolAtom b1, BoolAtom b2] -> + Right $ BoolAtom (b1 && b2) + }, + Function { funcName = "or", + funcType = [BoolAtomType, BoolAtomType, BoolAtomType], + funcBody = body $ \case + [BoolAtom b1, BoolAtom b2] -> + Right $ BoolAtom (b1 || b2) } + ] <> scientificAtomFunctions where body = FunctionBuiltInBody diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 0ffecdee..995114c8 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -57,8 +57,23 @@ testSelect = TestCase $ do ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#", "with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1}"), -- formula extension - ("SELECT status+10 FROM s", "(s : {attr_1:=add(@status,10)}) { attr_1 }") - ] + ("SELECT status+10 FROM s", "(s : {attr_1:=add(@status,10)}) { attr_1 }"), + -- extension and formula + ("SELECT status+10,city FROM s", "(s : {attr_1:=add(@status,10)}) {city,attr_1}"), + -- complex join condition + ("SELECT * FROM sp JOIN s ON s.s# = sp.s# AND s.s# = sp.s#","((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=and(eq(@`s.s#`,@`sp.s#`),eq(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1}"), + -- TABLE + ("TABLE s", "s") + -- any, all, some + -- IN() + -- where exists + --("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE s.s#=sp.s#)","s"), + -- where not exists + -- group by + -- group by having + -- limit + -- limit offset + ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, gre_graph = tgraph, @@ -69,7 +84,7 @@ testSelect = TestCase $ do check (sql, tutd) = do print sql --parse SQL - select <- case parse (selectP <* eof) "test" sql of + select <- case parse (queryExprP <* eof) "test" sql of Left err -> error (errorBundlePretty err) Right x -> do --print x From 8913f08a5c9070912f60066177d66f5980cdd1f1 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 9 Aug 2023 00:02:39 -0400 Subject: [PATCH 013/170] WIP convert SQL select into data frame expression to support ordering, limit, offset --- docs/dataframes.markdown | 8 +-- project-m36.cabal | 4 +- src/bin/SQL/Interpreter/Convert.hs | 61 ++++++++++++++--- .../Interpreter/RODatabaseContextOperator.hs | 17 +++-- src/lib/ProjectM36/DataFrame.hs | 13 +++- test/SQL/InterpreterTest.hs | 68 ++++++++++++------- 6 files changed, 122 insertions(+), 49 deletions(-) diff --git a/docs/dataframes.markdown b/docs/dataframes.markdown index 98fa1b3c..f35d3412 100644 --- a/docs/dataframes.markdown +++ b/docs/dataframes.markdown @@ -17,7 +17,7 @@ The default sort order is `ascending`. ## Examples ``` -TutorialD (master/main): :showdataframe s orderby {status} +TutorialD (master/main): :showdataframe (s) orderby {status} ┌──┬───────────┬─────────┬────────────┬────────────────┐ │DF│city::Text↕│s#::Text↕│sname::Text↕│status::Integer⬆│ ├──┼───────────┼─────────┼────────────┼────────────────┤ @@ -27,7 +27,7 @@ TutorialD (master/main): :showdataframe s orderby {status} │4 │"Athens" │"S5" │"Adams" │30 │ │5 │"Paris" │"S3" │"Blake" │30 │ └──┴───────────┴─────────┴────────────┴────────────────┘ -TutorialD (master/main): :showdataframe s{status} orderby {status} +TutorialD (master/main): :showdataframe (s{status}) orderby {status} ┌──┬────────────────┐ │DF│status::Integer⬆│ ├──┼────────────────┤ @@ -35,13 +35,13 @@ TutorialD (master/main): :showdataframe s{status} orderby {status} │2 │20 │ │3 │30 │ └──┴────────────────┘ -TutorialD (master/main): :showdataframe s{status} orderby {status descending} limit 1 +TutorialD (master/main): :showdataframe (s{status}) orderby {status descending} limit 1 ┌──┬────────────────┐ │DF│status::Integer⬇│ ├──┼────────────────┤ │1 │30 │ └──┴────────────────┘ -TutorialD (master/main): :showdataframe s{status} orderby {status descending} offset 1 limit 3 +TutorialD (master/main): :showdataframe (s{status}) orderby {status descending} offset 1 limit 3 ┌──┬────────────────┐ │DF│status::Integer⬇│ ├──┼────────────────┤ diff --git a/project-m36.cabal b/project-m36.cabal index 461d6f07..7d9d7371 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -318,7 +318,9 @@ Test-Suite test-sql import: commontest type: exitcode-stdio-1.0 main-is: SQL/InterpreterTest.hs - Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, SQL.Interpreter.Convert + Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, SQL.Interpreter.Convert, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator + TutorialD.Printer + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific, recursion-schemes Test-Suite test-tutoriald diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index e6acf92d..4c043f75 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -3,6 +3,7 @@ module SQL.Interpreter.Convert where import ProjectM36.Base import ProjectM36.Error +import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), AttributeOrder(..),Order(..)) import ProjectM36.AttributeNames as A import ProjectM36.Attribute as A import qualified ProjectM36.WithNameExpr as W @@ -32,17 +33,22 @@ class SQLConvert sqlexpr where convert :: TypeForRelExprF -> sqlexpr -> Either SQLError (ConverterF sqlexpr) instance SQLConvert Select where - type ConverterF Select = RelationalExpr + type ConverterF Select = DataFrameExpr convert typeF sel = do projF <- convert typeF (projectionClause sel) + let baseDFExpr = DataFrameExpr { convertExpr = ExistingRelation relationTrue, + orderExprs = [], + offset = Nothing, + limit = Nothing } case tableExpr sel of - Nothing -> pure $ ExistingRelation relationTrue + Nothing -> pure baseDFExpr Just tExpr -> do - (rvExpr, withNames) <- convert typeF tExpr + (dfExpr, withNames) <- convert typeF tExpr let withF = case withNames of [] -> id _ -> With withNames - pure (withF (projF rvExpr)) + pure (dfExpr { convertExpr = withF (projF (convertExpr dfExpr)) }) + tableAliasesAsWithNameAssocs :: TableAliasMap -> Either SQLError WithNamesAssocs tableAliasesAsWithNameAssocs tmap = @@ -98,7 +104,6 @@ instance SQLConvert [SelectItem] where pure $ acc { taskExtenders = AttributeExtendTupleExpr newAttrName atomExpr : taskExtenders acc, taskProjections = S.insert (QualifiedProjectionName [ProjectionName newAttrName]) (taskProjections acc) } - traceShowM ("selItems", selItems) task <- foldM selItemFolder emptyTask (zip [1::Int ..] selItems) --apply projections fProjection <- if S.null (taskProjections task) then @@ -123,8 +128,8 @@ instance SQLConvert [SelectItem] where pure (fProjection . fExtended . fRenames) instance SQLConvert TableExpr where - type ConverterF TableExpr = (RelationalExpr, WithNamesAssocs) - --does not handle non-relational aspects such as offset, order by, or limit + --pass with exprs up because they must be applied after applying projections + type ConverterF TableExpr = (DataFrameExpr, WithNamesAssocs) convert typeF tExpr = do (fromExpr, tableAliasMap) <- convert typeF (fromClause tExpr) let tableAliasMap' = M.filterWithKey filterRedundantAlias tableAliasMap @@ -139,11 +144,33 @@ instance SQLConvert TableExpr where restrictPredExpr <- convert typeF whereExpr pure $ Restrict restrictPredExpr fromExpr Nothing -> pure fromExpr - pure (expr', withExprs) + orderExprs <- convert typeF (orderByClause tExpr) + let dfExpr = DataFrameExpr { convertExpr = expr', + orderExprs = orderExprs, + offset = offsetClause tExpr, + limit = limitClause tExpr } + pure (dfExpr, withExprs) --group by --having - +instance SQLConvert [SortExpr] where + type ConverterF [SortExpr] = [AttributeOrderExpr] + convert typeF exprs = mapM converter exprs + where + converter (SortExpr sexpr mDirection mNullsOrder) = do + atomExpr <- convert typeF sexpr + attrn <- case atomExpr of + AttributeAtomExpr aname -> pure aname + x -> Left (NotSupportedError (T.pack (show x))) + let ordering = case mDirection of + Nothing -> AscendingOrder + Just Ascending -> AscendingOrder + Just Descending -> DescendingOrder + case mNullsOrder of + Nothing -> pure () + Just x -> Left (NotSupportedError (T.pack (show x))) + pure (AttributeOrderExpr attrn ordering) + instance SQLConvert [TableRef] where -- returns base relation expressions plus top-level renames required type ConverterF [TableRef] = (RelationalExpr, TableAliasMap) @@ -302,6 +329,20 @@ instance SQLConvert RestrictionExpr where b <- convert typeF exprB f <- lookupFunc qn pure (AtomExprPredicate (f [a,b])) + InExpr inOrNotIn sexpr (InList matches') -> do + eqExpr <- convert typeF sexpr + let (match:matches) = reverse matches' + firstItem <- convert typeF match + let inFunc a b = AtomExprPredicate (FunctionAtomExpr "eq" [a,b] ()) + predExpr' = inFunc eqExpr firstItem + folder predExpr'' sexprItem = do + item <- convert typeF sexprItem + pure $ OrPredicate (inFunc eqExpr item) predExpr'' + res <- foldM folder predExpr' matches --be careful here once we introduce NULLs + case inOrNotIn of + In -> pure res + NotIn -> pure (NotPredicate res) + -- this could be amended to support more complex expressions such as coalesce by returning an [AtomExpr] -> AtomExpr function lookupFunc :: QualifiedName -> Either SQLError ([AtomExpr] -> AtomExpr) @@ -340,6 +381,8 @@ instance SQLConvert ScalarExpr where b <- convert typeF exprB f <- lookupFunc qn pure $ f [a,b] +-- PrefixOperator qn expr -> do + instance SQLConvert JoinOnCondition where type ConverterF JoinOnCondition = (RelationalExpr -> RelationalExpr) diff --git a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs index 3a233563..cd8c575d 100644 --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -202,13 +202,16 @@ interpretRODatabaseContextOp sessionId conn tutdstring = case parse roDatabaseCo showDataFrameP :: Parser RODatabaseContextOperator showDataFrameP = do colonOp ":showdataframe" - relExpr <- relExprP - reservedOp "orderby" - attrOrdersExpr <- attrOrdersExprP - mbOffset <- optional offsetP - mbLimit <- optional limitP - pure $ ShowDataFrame (DF.DataFrameExpr relExpr attrOrdersExpr mbOffset mbLimit) + dfExpr <- dataFrameP + pure (ShowDataFrame dfExpr) +dataFrameP :: Parser DF.DataFrameExpr +dataFrameP = do + relExpr <- parens relExprP + attrOrdersExpr <- try attrOrdersExprP <|> pure [] + mbLimit <- optional limitP + mbOffset <- optional offsetP + pure $ DF.DataFrameExpr relExpr attrOrdersExpr mbOffset mbLimit offsetP :: Parser Integer offsetP = do @@ -221,7 +224,7 @@ limitP = do natural attrOrdersExprP :: Parser [DF.AttributeOrderExpr] -attrOrdersExprP = braces (sepBy attrOrderExprP comma) +attrOrdersExprP = reserved "orderby" *> braces (sepBy attrOrderExprP comma) attrOrderExprP :: Parser DF.AttributeOrderExpr attrOrderExprP = DF.AttributeOrderExpr <$> identifier <*> orderP diff --git a/src/lib/ProjectM36/DataFrame.hs b/src/lib/ProjectM36/DataFrame.hs index 98b912b5..b7576609 100644 --- a/src/lib/ProjectM36/DataFrame.hs +++ b/src/lib/ProjectM36/DataFrame.hs @@ -23,10 +23,10 @@ import Data.Monoid #endif data AttributeOrderExpr = AttributeOrderExpr AttributeName Order - deriving (Show, Generic) + deriving (Show, Generic, Eq) data AttributeOrder = AttributeOrder AttributeName Order - deriving (Show, Generic) + deriving (Show, Generic, Eq) data Order = AscendingOrder | DescendingOrder deriving (Eq, Show, Generic) @@ -127,7 +127,14 @@ data DataFrameExpr = DataFrameExpr { offset :: Maybe Integer, limit :: Maybe Integer } - deriving (Show, Generic) + deriving (Show, Generic, Eq) + +-- | Returns a data frame expression without any sorting or limits. +nakedDataFrameExpr :: RelationalExpr -> DataFrameExpr +nakedDataFrameExpr rexpr = DataFrameExpr { convertExpr = rexpr, + orderExprs = [], + offset = Nothing, + limit = Nothing } dataFrameAsHTML :: DataFrame -> T.Text -- web browsers don't display tables with empty cells or empty headers, so we have to insert some placeholders- it's not technically the same, but looks as expected in the browser diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 995114c8..cd74bf70 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} import SQL.Interpreter.Select import SQL.Interpreter.Convert -import TutorialD.Interpreter.RelationalExpr +--import TutorialD.Interpreter.RelationalExpr +import TutorialD.Interpreter.RODatabaseContextOperator import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph import ProjectM36.DateExamples @@ -26,53 +27,67 @@ testSelect = TestCase $ do let p tin = parse selectP "test" tin readTests = [ -- simple relvar - ("SELECT * FROM test", "test"), + ("SELECT * FROM test", "(test)"), -- simple projection - ("SELECT a FROM test", "test{a}"), + ("SELECT a FROM test", "(test{a})"), -- restriction - ("SELECT a FROM test where b=3","(test where b=3){a}"), + ("SELECT a FROM test where b=3","((test where b=3){a})"), -- restriction - ("SELECT a,b FROM test where b>3","(test where gt(@b,3)){a,b}"), + ("SELECT a,b FROM test where b>3","((test where gt(@b,3)){a,b})"), -- extension mixed with projection - ("SELECT a,b,10 FROM test","(test:{attr_3:=10}){a,b,attr_3}"), + ("SELECT a,b,10 FROM test","((test:{attr_3:=10}){a,b,attr_3})"), -- column alias - ("SELECT a AS x FROM test","(test rename {a as x}){x}"), + ("SELECT a AS x FROM test","((test rename {a as x}){x})"), -- case insensitivity - ("sElECt A aS X FRoM TeST","(test rename {a as x}){x}"), + ("sElECt A aS X FRoM TeST","((test rename {a as x}){x})"), --column from aliased table - ("SELECT sup.city FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`})"), + ("SELECT sup.city FROM s AS sup","(with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`}))"), --projection with alias - ("SELECT sup.city,sup.sname FROM s AS sup","with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`})"), - ("SELECT sup.* FROM s as sup","with (sup as s) (sup{all from sup})"), + ("SELECT sup.city,sup.sname FROM s AS sup","(with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`}))"), + ("SELECT sup.* FROM s as sup","(with (sup as s) (sup{all from sup}))"), -- natural join - ("SELECT * FROM s NATURAL JOIN sp","s join sp"), + ("SELECT * FROM s NATURAL JOIN sp","(s join sp)"), -- cross join - ("SELECT * FROM s CROSS JOIN sp", "(s rename {s# as `s.s#`}) join sp"), + ("SELECT * FROM s CROSS JOIN sp", "((s rename {s# as `s.s#`}) join sp)"), -- unaliased join using ("SELECT * FROM sp INNER JOIN sp USING (\"s#\")", - "(sp rename {p# as `sp.p#`, qty as `sp.qty`}) join sp"), + "((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join sp)"), -- unaliased join - ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1}"), + ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1})"), -- aliased join on ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#", - "with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1}"), + "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})"), -- formula extension - ("SELECT status+10 FROM s", "(s : {attr_1:=add(@status,10)}) { attr_1 }"), + ("SELECT status+10 FROM s", "((s : {attr_1:=add(@status,10)}) { attr_1 })"), -- extension and formula - ("SELECT status+10,city FROM s", "(s : {attr_1:=add(@status,10)}) {city,attr_1}"), + ("SELECT status+10,city FROM s", "((s : {attr_1:=add(@status,10)}) {city,attr_1})"), -- complex join condition - ("SELECT * FROM sp JOIN s ON s.s# = sp.s# AND s.s# = sp.s#","((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=and(eq(@`s.s#`,@`sp.s#`),eq(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1}"), + ("SELECT * FROM sp JOIN s ON s.s# = sp.s# AND s.s# = sp.s#", + "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=and(eq(@`s.s#`,@`sp.s#`),eq(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})"), -- TABLE - ("TABLE s", "s") + ("TABLE s", "(s)"), -- any, all, some -- IN() + ("SELECT * FROM s WHERE s# IN ('S1','S2')", "(s where eq(@s#,\"S1\") or eq(@s#,\"S2\"))"), + -- NOT IN() + ("SELECT * FROM s WHERE s# NOT IN ('S1','S2')", + "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))"), -- where exists --("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE s.s#=sp.s#)","s"), -- where not exists -- group by -- group by having -- limit + ("SELECT * FROM s LIMIT 10","(s) limit 10"), + -- offset + ("SELECT * FROM s OFFSET 10","(s) offset 10"), -- limit offset + ("SELECT * FROM s LIMIT 10 OFFSET 20","(s) limit 10 offset 20"), + -- order by + ("SELECT * FROM s ORDER BY status","(s) orderby {status}"), + -- order by descending + ("SELECT * FROM s ORDER BY status DESC,city","(s) orderby {status descending,city}") + -- CTEs ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, @@ -82,20 +97,23 @@ testSelect = TestCase $ do let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr) runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) check (sql, tutd) = do - print sql + --print sql --parse SQL select <- case parse (queryExprP <* eof) "test" sql of Left err -> error (errorBundlePretty err) Right x -> do - --print x + print x pure x --parse tutd - relExpr <- case parse (relExprP <* eof) "test" tutd of + relExpr <- case parse (dataFrameP <* eof) "test" tutd of Left err -> error (errorBundlePretty err) - Right x -> pure x + Right x -> do + --print x + pure x selectAsRelExpr <- case convert typeF select of Left err -> error (show err) - Right x -> pure x + Right x -> do + pure x --print ("selectAsRelExpr"::String, selectAsRelExpr) assertEqual (T.unpack sql) relExpr selectAsRelExpr From 777285bbb5e751a9de294386db114a4868a454cf Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 10 Aug 2023 18:55:46 -0400 Subject: [PATCH 014/170] WIP add SQL CTE support --- src/bin/SQL/Interpreter/Convert.hs | 28 +++++++++++++++-- src/bin/SQL/Interpreter/Select.hs | 30 +++++++++++++++++-- src/lib/ProjectM36/AtomFunctions/Primitive.hs | 2 ++ src/lib/ProjectM36/DataFrame.hs | 20 ++++++++----- test/SQL/InterpreterTest.hs | 8 ++--- 5 files changed, 70 insertions(+), 18 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 4c043f75..37a78400 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -3,7 +3,7 @@ module SQL.Interpreter.Convert where import ProjectM36.Base import ProjectM36.Error -import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), AttributeOrder(..),Order(..)) +import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), AttributeOrder(..),Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A import ProjectM36.Attribute as A import qualified ProjectM36.WithNameExpr as W @@ -16,6 +16,8 @@ import qualified Data.Set as S import qualified Data.Map as M import Data.List (foldl') import qualified Data.Functor.Foldable as Fold +import qualified Data.List.NonEmpty as NE +import Control.Monad (when) import Debug.Trace @@ -36,6 +38,13 @@ instance SQLConvert Select where type ConverterF Select = DataFrameExpr convert typeF sel = do projF <- convert typeF (projectionClause sel) + -- we have explicit with clauses written by the user, but also our own implementation-specific with expressions + explicitWithF <- case withClause sel of + Nothing -> pure id + Just wClause -> do + wExprs <- convert typeF wClause + pure (With wExprs) + let baseDFExpr = DataFrameExpr { convertExpr = ExistingRelation relationTrue, orderExprs = [], offset = Nothing, @@ -46,8 +55,8 @@ instance SQLConvert Select where (dfExpr, withNames) <- convert typeF tExpr let withF = case withNames of [] -> id - _ -> With withNames - pure (dfExpr { convertExpr = withF (projF (convertExpr dfExpr)) }) + _ -> With withNames + pure (dfExpr { convertExpr = explicitWithF (withF (projF (convertExpr dfExpr))) }) tableAliasesAsWithNameAssocs :: TableAliasMap -> Either SQLError WithNamesAssocs @@ -422,6 +431,19 @@ instance SQLConvert QualifiedProjectionName where names' <- mapM namer names pure (T.concat names') +instance SQLConvert WithClause where + type ConverterF WithClause = WithNamesAssocs + convert typeF (WithClause True _) = Left (NotSupportedError "recursive CTEs") + convert typeF (WithClause False ctes) = do + let mapper (WithExpr (UnqualifiedName nam) subquery) = do + dfExpr <- convert typeF subquery + -- we don't support dataframe features in the cte query + when (usesDataFrameFeatures dfExpr) $ Left (NotSupportedError "ORDER BY/LIMIT/OFFSET in CTE subexpression") + pure (WithNameExpr nam (), (convertExpr dfExpr)) + -- if the subquery is a Select, how do I get a rvexpr out of it rather than a data frame- perhaps a different conversion function? + mapM mapper (NE.toList ctes) + + -- | Used to remap SQL qualified names to new names to prevent conflicts in join conditions. renameIdentifier :: (QualifiedName -> QualifiedName) -> ScalarExpr -> ScalarExpr renameIdentifier renamer sexpr = Fold.cata renamer' sexpr diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 67cdf8d9..59cab0b9 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -8,18 +8,29 @@ import Data.Text (Text, splitOn) import qualified Data.Text as T import Data.Functor import Data.Functor.Foldable.TH +import qualified Data.List.NonEmpty as NE -- we use an intermediate data structure because it may need to be probed into order to create a proper relational expression data Select = Select { distinctness :: Maybe Distinctness, projectionClause :: [SelectItem], - tableExpr :: Maybe TableExpr + tableExpr :: Maybe TableExpr, + withClause :: Maybe WithClause } deriving (Show, Eq) emptySelect :: Select emptySelect = Select { distinctness = Nothing, projectionClause = [], - tableExpr = Nothing } + tableExpr = Nothing, + withClause = Nothing + } + +data WithClause = WithClause { isRecursive :: Bool, + withExprs :: NE.NonEmpty WithExpr } + deriving (Show, Eq) + +data WithExpr = WithExpr UnqualifiedName Select + deriving (Show, Eq) data InFlag = In | NotIn deriving (Show, Eq) @@ -131,13 +142,15 @@ tableP = do selectP :: Parser Select selectP = do + withClause' <- optional withP reserved "select" -- distinctOptions projection <- selectItemListP tExpr <- optional tableExprP pure (Select { distinctness = Nothing, projectionClause = projection, - tableExpr = tExpr + tableExpr = tExpr, + withClause = withClause' }) type SelectItem = (ProjectionScalarExpr, Maybe AliasName) @@ -393,6 +406,17 @@ limitP = optional (reserved "limit" *> integer) offsetP :: Parser (Maybe Integer) offsetP = optional (reserved "offset" *> integer) + +withP :: Parser WithClause +withP = do + reserved "with" + recursive <- try (reserved "recursive" *> pure True) <|> pure False + wExprs <- sepByComma1 $ do + wName <- unqualifiedNameP + reserved "as" + wSelect <- parens selectP + pure (WithExpr wName wSelect) + pure (WithClause recursive (NE.fromList wExprs)) makeBaseFunctor ''ScalarExprBase diff --git a/src/lib/ProjectM36/AtomFunctions/Primitive.hs b/src/lib/ProjectM36/AtomFunctions/Primitive.hs index 9fc38c98..ef5699a2 100644 --- a/src/lib/ProjectM36/AtomFunctions/Primitive.hs +++ b/src/lib/ProjectM36/AtomFunctions/Primitive.hs @@ -98,12 +98,14 @@ primitiveAtomFunctions = HS.fromList [ funcBody = body $ \case [BoolAtom b1, BoolAtom b2] -> Right $ BoolAtom (b1 && b2) + _ -> Left AtomFunctionTypeMismatchError }, Function { funcName = "or", funcType = [BoolAtomType, BoolAtomType, BoolAtomType], funcBody = body $ \case [BoolAtom b1, BoolAtom b2] -> Right $ BoolAtom (b1 || b2) + _ -> Left AtomFunctionTypeMismatchError } ] <> scientificAtomFunctions diff --git a/src/lib/ProjectM36/DataFrame.hs b/src/lib/ProjectM36/DataFrame.hs index b7576609..75fb418a 100644 --- a/src/lib/ProjectM36/DataFrame.hs +++ b/src/lib/ProjectM36/DataFrame.hs @@ -2,7 +2,7 @@ {- A dataframe is a strongly-typed, ordered list of named tuples. A dataframe differs from a relation in that its tuples are ordered.-} module ProjectM36.DataFrame where import ProjectM36.Base -import ProjectM36.Attribute as A hiding (drop) +import qualified ProjectM36.Attribute as A hiding (drop) import ProjectM36.Error import qualified ProjectM36.Relation as R import ProjectM36.Relation.Show.Term @@ -53,7 +53,7 @@ data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom) sortDataFrameBy :: [AttributeOrder] -> DataFrame -> Either RelationalError DataFrame sortDataFrameBy attrOrders frame = do attrs <- mapM (\(AttributeOrder nam _) -> A.attributeForName nam (attributes frame)) attrOrders - mapM_ (\attr -> unless (isSortableAtomType (atomType attr)) $ Left (AttributeNotSortableError attr)) attrs + mapM_ (\attr -> unless (isSortableAtomType (A.atomType attr)) $ Left (AttributeNotSortableError attr)) attrs pure $ DataFrame attrOrders (attributes frame) (sortTuplesBy (compareTupleByAttributeOrders attrOrders) (tuples frame)) sortTuplesBy :: (DataFrameTuple -> DataFrameTuple -> Ordering) -> [DataFrameTuple] -> [DataFrameTuple] @@ -79,7 +79,7 @@ compareTupleByOneAttributeName attr tuple1 tuple2 = Right atom2 -> compareAtoms atom1 atom2 atomForAttributeName :: AttributeName -> DataFrameTuple -> Either RelationalError Atom -atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) (attributesVec tupAttrs) of +atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> A.attributeName attr == attrName) (attributesVec tupAttrs) of Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName)) Just index -> case tupVec V.!? index of Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName)) @@ -106,10 +106,10 @@ showDataFrame = renderTable . dataFrameAsTable dataFrameAsTable :: DataFrame -> Table dataFrameAsTable df = (header, body) where - oAttrNames = orderedAttributeNames (attributes df) - oAttrs = orderedAttributes (attributes df) + oAttrNames = A.orderedAttributeNames (attributes df) + oAttrs = A.orderedAttributes (attributes df) header = "DF" : map dfPrettyAttribute oAttrs - dfPrettyAttribute attr = prettyAttribute attr <> case L.find (\(AttributeOrder nam _) -> nam == attributeName attr) (orders df) of + dfPrettyAttribute attr = prettyAttribute attr <> case L.find (\(AttributeOrder nam _) -> nam == A.attributeName attr) (orders df) of Nothing -> arbitrary Just (AttributeOrder _ AscendingOrder) -> ascending Just (AttributeOrder _ DescendingOrder) -> descending @@ -129,6 +129,10 @@ data DataFrameExpr = DataFrameExpr { } deriving (Show, Generic, Eq) +-- | True iff dataframe features are required to execute this expression, False if this expression could be evaluated as a relational expression (no sorting, limit, or offset). +usesDataFrameFeatures :: DataFrameExpr -> Bool +usesDataFrameFeatures df = not (null (orderExprs df)) || isJust (offset df) || isJust (limit df) + -- | Returns a data frame expression without any sorting or limits. nakedDataFrameExpr :: RelationalExpr -> DataFrameExpr nakedDataFrameExpr rexpr = DataFrameExpr { convertExpr = rexpr, @@ -167,7 +171,7 @@ tuplesAsHTML = foldr folder "" folder tuple acc = acc <> tupleAsHTML tuple tupleAssocs :: DataFrameTuple -> [(AttributeName, Atom)] -tupleAssocs (DataFrameTuple attrs tupVec) = V.toList $ V.map (first attributeName) (V.zip (attributesVec attrs) tupVec) +tupleAssocs (DataFrameTuple attrs tupVec) = V.toList $ V.map (first A.attributeName) (V.zip (attributesVec attrs) tupVec) tupleAsHTML :: DataFrameTuple -> T.Text @@ -181,7 +185,7 @@ tupleAsHTML tuple = "" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <> attributesAsHTML :: Attributes -> [AttributeOrder] -> T.Text attributesAsHTML attrs orders' = "" <> T.concat (map oneAttrHTML (A.toList attrs)) <> "" where - oneAttrHTML attr = "" + oneAttrHTML attr = "" ordering attrName = " " <> case L.find (\(AttributeOrder nam _) -> nam == attrName) orders' of Nothing -> "(arb)" Just (AttributeOrder _ AscendingOrder) -> "(asc)" diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index cd74bf70..d191252a 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -24,8 +24,7 @@ testSelect :: Test testSelect = TestCase $ do -- check that SQL and tutd compile to same thing (tgraph,transId) <- freshTransactionGraph dateExamples - let p tin = parse selectP "test" tin - readTests = [ + let readTests = [ -- simple relvar ("SELECT * FROM test", "(test)"), -- simple projection @@ -86,8 +85,9 @@ testSelect = TestCase $ do -- order by ("SELECT * FROM s ORDER BY status","(s) orderby {status}"), -- order by descending - ("SELECT * FROM s ORDER BY status DESC,city","(s) orderby {status descending,city}") + ("SELECT * FROM s ORDER BY status DESC,city","(s) orderby {status descending,city}"), -- CTEs + ("WITH x AS (SELECT * FROM s) SELECT * FROM x", "(with (x as s) x)") ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, @@ -119,5 +119,5 @@ testSelect = TestCase $ do assertEqual (T.unpack sql) relExpr selectAsRelExpr mapM_ check readTests - assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") +-- assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") From 70846107906d0eaea06011fb294b129489ef6815 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 27 Aug 2023 00:17:26 -0400 Subject: [PATCH 015/170] WIP after big refactor checkpoint --- src/bin/SQL/Interpreter/Convert.hs | 603 ++++++++++++++++++++++++++--- src/bin/SQL/Interpreter/Select.hs | 20 +- test/SQL/InterpreterTest.hs | 36 +- 3 files changed, 588 insertions(+), 71 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 37a78400..0ad34f2c 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -1,5 +1,5 @@ --convert SQL into relational or database context expressions -{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables, TypeApplications, GeneralizedNewtypeDeriving #-} module SQL.Interpreter.Convert where import ProjectM36.Base import ProjectM36.Error @@ -18,6 +18,7 @@ import Data.List (foldl') import qualified Data.Functor.Foldable as Fold import qualified Data.List.NonEmpty as NE import Control.Monad (when) +import ProjectM36.DataTypes.Maybe import Debug.Trace @@ -25,11 +26,510 @@ data SQLError = NotSupportedError T.Text | TypeMismatchError AtomType AtomType | NoSuchSQLFunctionError QualifiedName | DuplicateTableReferenceError QualifiedName | + MissingTableReferenceError QualifiedName | + ColumnResolutionError QualifiedName | + UnexpectedRelationalExprError RelationalExpr | + AmbiguousColumnResolutionError QualifiedName | SQLRelationalError RelationalError deriving (Show, Eq) type TypeForRelExprF = RelationalExpr -> Either RelationalError Relation +data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set QualifiedProjectionName, + taskRenames :: [(QualifiedProjectionName, AliasName)], + taskExtenders :: [ExtendTupleExpr] + } deriving (Show, Eq) + +--over the course of conversion, we collect all the table aliases we encounter, including non-aliased table references, including the type of the table +newtype TableContext = TableContext (M.Map QualifiedName (RelationalExpr, Attributes)) + deriving (Semigroup, Monoid, Show, Eq) + + +tableAliasesAsWithNameAssocs :: TableContext -> Either SQLError WithNamesAssocs +tableAliasesAsWithNameAssocs (TableContext tmap) = + filter notSelfRef <$> mapM mapper (M.toList tmap) + where + notSelfRef (WithNameExpr nam (), RelationVariable nam' ()) | nam == nam' = False + | otherwise = True + notSelfRef _ = True + mapper :: (QualifiedName, (RelationalExpr, Attributes)) -> Either SQLError (WithNameExpr, RelationalExpr) + mapper (QualifiedName [nam], (rvExpr, _)) = pure (WithNameExpr nam (), rvExpr) + mapper (qn, _) = Left (NotSupportedError ("schema qualified table names: " <> T.pack (show qn))) + +-- | Insert another table into the TableContext. +insertTable :: QualifiedName -> RelationalExpr -> Attributes -> TableContext -> Either SQLError TableContext +insertTable qn expr rtype (TableContext map') = + case M.lookup qn map' of + Nothing -> pure $ TableContext $ M.insert qn (expr, rtype) map' + Just _ -> Left (DuplicateTableReferenceError qn) + +lookupTable :: QualifiedName -> TableContext -> Either SQLError (RelationalExpr, Attributes) +lookupTable qn (TableContext map') = + case M.lookup qn map' of + Nothing -> Left (MissingTableReferenceError qn) + Just res -> pure res + +replaceTableName :: QualifiedName -> QualifiedName -> TableContext -> Either SQLError TableContext +replaceTableName oldName newName (TableContext tctx) = + case M.lookup oldName tctx of + Nothing -> Left (MissingTableReferenceError oldName) + Just match -> pure $ TableContext $ M.insert newName match (M.delete oldName tctx) + +-- | Find a column name or column alias in the underlying table context. +findColumn :: QualifiedName -> TableContext -> [QualifiedName] +findColumn colName (TableContext tMap) = + M.foldrWithKey folder [] tMap + where + folder (QualifiedName [tAlias]) (rvExpr, rtype) acc = + case colName of + QualifiedName [colName'] -> + if S.member colName' (attributeNameSet rtype) then + QualifiedName [tAlias] : acc + else + acc + QualifiedName [tPrefix, colName'] -> + if tAlias == tPrefix && colName' == colName' then + QualifiedName [tAlias] : acc + else + acc + _ -> acc + +wrapTypeF :: TypeForRelExprF -> RelationalExpr -> Either SQLError Relation +wrapTypeF typeF relExpr = + case typeF relExpr of + Left relError -> Left (SQLRelationalError relError) + Right v -> pure v + + +-- | Return the table alias for the column name iff the attribute is unique. Used for attribute resolution. +tableAliasForColumnName :: TypeForRelExprF -> QualifiedName -> TableContext -> Either SQLError QualifiedName +-- the table alias is included +tableAliasForColumnName typeF qn@(QualifiedName [tAlias, _]) (TableContext tMap) = do + if M.member qn tMap then + pure (QualifiedName [tAlias]) + else + Left (ColumnResolutionError qn) +tableAliasForColumnName typeF qn@(QualifiedName [colName]) (TableContext tMap) = do + --look up the column name in all possible tables + res <- foldM folder Nothing (M.toList tMap) + case res of + Just res -> pure res + Nothing -> Left (ColumnResolutionError qn) + where +-- folder :: Maybe QualifiedName -> (QualifiedName, RelationalExpr) -> + folder Just{} _ = Left (AmbiguousColumnResolutionError qn) + folder Nothing (qn'@(QualifiedName [tableAlias]), (rvExpr,_)) = do + tRel <- wrapTypeF typeF rvExpr -- we could cache this in the table alias map ADT + --traceShowM ("findColName", rvExpr, tRel) + if colName `S.member` attributeNameSet (attributes tRel) then + pure (Just (QualifiedName [tableAlias, colName])) + else pure Nothing + +convertSelect :: TypeForRelExprF -> Select -> Either SQLError DataFrameExpr +convertSelect typeF sel = do + let baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () []), + orderExprs = [], + offset = Nothing, + limit = Nothing } + -- extract all mentioned tables into the table alias map for + (dfExpr, tAliasMap, colRemap) <- case tableExpr sel of + Nothing -> pure (baseDFExpr, mempty, mempty) + Just tExpr -> convertTableExpr typeF tExpr +-- traceShowM ("table aliases", tAliasMap) + explicitWithF <- case withClause sel of + Nothing -> pure id + Just wClause -> do + wExprs <- convertWithClause typeF wClause + pure (With wExprs) + + -- convert projection using table alias map to resolve column names + projF <- convertProjection typeF tAliasMap (projectionClause sel) + -- add with clauses + + withAssocs <- tableAliasesAsWithNameAssocs tAliasMap + let withF = case withAssocs of + [] -> id + _ -> With withAssocs + -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes + pure (dfExpr { convertExpr = explicitWithF (withF (projF (convertExpr dfExpr))) }) + +convertSelectItem :: TypeForRelExprF -> TableContext -> SelectItemsConvertTask -> (Int,SelectItem) -> Either SQLError SelectItemsConvertTask +convertSelectItem typeF tAliasMap acc (c,selItem) = + case selItem of + -- select * from x + (Identifier (QualifiedProjectionName [Asterisk]), Nothing) -> + pure acc + -- select sup.* from s as sup + (Identifier qpn@(QualifiedProjectionName [ProjectionName _, Asterisk]), Nothing) -> + pure $ acc { taskProjections = S.insert qpn (taskProjections acc) } + -- select a from x + (Identifier qpn@(QualifiedProjectionName [ProjectionName col]), Nothing) -> do + --look up unaliased column name + _ <- colinfo qpn + pure $ acc { taskProjections = S.insert qpn (taskProjections acc) + } + -- select city as x from s + (Identifier qpn@(QualifiedProjectionName [ProjectionName _]), Just newName@(AliasName newNameTxt)) -> do + pure $ acc { taskProjections = S.insert (QualifiedProjectionName [ProjectionName newNameTxt]) (taskProjections acc), + taskRenames = taskRenames acc <> [(qpn, newName)] } + -- select s.city from s + (Identifier qpn@(QualifiedProjectionName [ProjectionName tname, ProjectionName colname]), Nothing) -> do + --lookup column renaming, if applicable + pure $ acc { taskProjections = S.insert qpn (taskProjections acc), + taskRenames = taskRenames acc <> [(QualifiedProjectionName [ProjectionName colname], AliasName (T.intercalate "." [tname,colname]))] } + -- other exprs + (scalarExpr, mAlias) -> do + let attrName' (Just (AliasName nam)) _ = nam + attrName' Nothing c = "attr_" <> T.pack (show c) + atomExpr <- convertProjectionScalarExpr typeF scalarExpr + let newAttrName = attrName' mAlias c + -- we need to apply the projections after the extension! + pure $ acc { taskExtenders = AttributeExtendTupleExpr newAttrName atomExpr : taskExtenders acc, + taskProjections = S.insert (QualifiedProjectionName [ProjectionName newAttrName]) (taskProjections acc) + } + where + colinfo (QualifiedProjectionName [ProjectionName name]) = + case tableAliasForColumnName typeF (QualifiedName [name]) tAliasMap of + Left err -> Left err + Right (QualifiedName names') -> pure $ AliasName (T.intercalate "." names') + + +convertProjection :: TypeForRelExprF -> TableContext -> [SelectItem] -> Either SQLError (RelationalExpr -> RelationalExpr) +convertProjection typeF tAliasMap selItems = do + let emptyTask = SelectItemsConvertTask { taskProjections = S.empty, + taskRenames = mempty, + taskExtenders = mempty } + attrName' (Just (AliasName nam)) _ = nam + attrName' Nothing c = "attr_" <> T.pack (show c) + task <- foldM (convertSelectItem typeF tAliasMap) emptyTask (zip [1::Int ..] selItems) + --apply projections + fProjection <- if S.null (taskProjections task) then + pure id + else do + let projFolder (attrNames, b) (QualifiedProjectionName [ProjectionName nam]) = + pure (S.insert nam attrNames, b) + projFolder (attrNames, b) (QualifiedProjectionName [ProjectionName nameA, ProjectionName nameB]) = + pure $ (S.insert (T.concat [nameA, ".", nameB]) attrNames, b) + projFolder (attrNames, relExprAttributes) (QualifiedProjectionName [ProjectionName tname, Asterisk]) = + pure $ (attrNames, relExprAttributes <> [tname]) + (attrNames, relExprRvs) <- foldM projFolder mempty (S.toList (taskProjections task)) + let attrsProj = A.some (map (\rv -> RelationalExprAttributeNames (RelationVariable rv ())) relExprRvs <> [AttributeNames attrNames]) + pure $ Project attrsProj + -- apply extensions + let fExtended = foldr (\ext acc -> (Extend ext) . acc) id (taskExtenders task) + -- apply rename + renamesSet <- foldM (\acc (qProjName, (AliasName newName)) -> do + oldName <- convertProjectionName qProjName + pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) + let fRenames = if S.null renamesSet then id else Rename renamesSet + pure (fProjection . fExtended . fRenames) + +convertProjectionName :: QualifiedProjectionName -> Either SQLError AttributeName +convertProjectionName (QualifiedProjectionName names) = do + let namer (ProjectionName t) = pure t + namer Asterisk = Left (NotSupportedError "asterisk in projection conversion") + names' <- mapM namer names + pure (T.concat names') + +convertQualifiedName :: QualifiedName -> Either SQLError AttributeName +convertQualifiedName (QualifiedName ts) = pure $ T.intercalate "." ts + +convertQualifiedProjectionName :: QualifiedProjectionName -> Either SQLError AttributeName +convertQualifiedProjectionName (QualifiedProjectionName names) = do + let namer (ProjectionName t) = pure t + namer Asterisk = error "wrong asterisk" + names' <- mapM namer names + pure (T.concat names') + + +convertTableExpr :: TypeForRelExprF -> TableExpr -> Either SQLError (DataFrameExpr, TableContext, ColumnRemap) +convertTableExpr typeF tExpr = do + (fromExpr, tableAliasMap, columnRemap) <- convertFromClause typeF (fromClause tExpr) +{- let tableAliasMap' = M.filterWithKey filterRedundantAlias tableAliasMap + filterRedundantAlias (QualifiedName [nam]) (RelationVariable nam' ()) + | nam == nam' = False + filterRedundantAlias _ _ = True-} +{- withExprs <- mapM (\(qnam, expr) -> do + nam <- convertQualifiedName qnam + pure (WithNameExpr nam (), expr)) (M.toList tableAliasMap')-} + + + expr' <- case whereClause tExpr of + Just whereExpr -> do + restrictPredExpr <- convertWhereClause typeF whereExpr + pure $ Restrict restrictPredExpr fromExpr + Nothing -> pure fromExpr + orderExprs <- convertOrderByClause typeF (orderByClause tExpr) + let dfExpr = DataFrameExpr { convertExpr = expr', + orderExprs = orderExprs, + offset = offsetClause tExpr, + limit = limitClause tExpr } + pure (dfExpr, tableAliasMap, columnRemap) + +convertWhereClause :: TypeForRelExprF -> RestrictionExpr -> Either SQLError RestrictionPredicateExpr +convertWhereClause typeF (RestrictionExpr rexpr) = do + let wrongType t = Left $ TypeMismatchError t BoolAtomType --must be boolean expression + attrName' (QualifiedName ts) = T.intercalate "." ts + case rexpr of + IntegerLiteral{} -> wrongType IntegerAtomType + DoubleLiteral{} -> wrongType DoubleAtomType + StringLiteral{} -> wrongType TextAtomType + Identifier i -> wrongType TextAtomType -- could be a better error here + BinaryOperator (Identifier a) (QualifiedName ["="]) exprMatch -> --we don't know here if this results in a boolean expression, so we pass it down + AttributeEqualityPredicate (attrName' a) <$> convertScalarExpr typeF exprMatch + BinaryOperator exprA qn exprB -> do + a <- convertScalarExpr typeF exprA + b <- convertScalarExpr typeF exprB + f <- lookupFunc qn + pure (AtomExprPredicate (f [a,b])) + InExpr inOrNotIn sexpr (InList matches') -> do + eqExpr <- convertScalarExpr typeF sexpr + let (match:matches) = reverse matches' + firstItem <- convertScalarExpr typeF match + let inFunc a b = AtomExprPredicate (FunctionAtomExpr "eq" [a,b] ()) + predExpr' = inFunc eqExpr firstItem + folder predExpr'' sexprItem = do + item <- convertScalarExpr typeF sexprItem + pure $ OrPredicate (inFunc eqExpr item) predExpr'' + res <- foldM folder predExpr' matches --be careful here once we introduce NULLs + case inOrNotIn of + In -> pure res + NotIn -> pure (NotPredicate res) + ExistsExpr subQ -> do + dfExpr <- convertSelect typeF subQ + --pretty sure I have to rename attributes in both the top-level query and in this one to prevent attribute conflicts- we can't rename all the attributes in the subquery, because the renamer won't know which attributes actually refer to the top-level attributes- should we just prefix all attributes unconditionally or send a signal upstream to rename attributes? + when (usesDataFrameFeatures dfExpr) $ Left (NotSupportedError "ORDER BY/LIMIT/OFFSET in EXISTS subquery") + let rexpr = Equals (Project A.empty (convertExpr dfExpr)) (RelationVariable "true" ()) + pure (RelationalExprPredicate rexpr) + + +convertScalarExpr :: TypeForRelExprF -> ScalarExpr -> Either SQLError AtomExpr +convertScalarExpr typeF expr = do + let naked = pure . NakedAtomExpr + case expr of + IntegerLiteral i -> naked (IntegerAtom i) + DoubleLiteral d -> naked (DoubleAtom d) + StringLiteral s -> naked (TextAtom s) + -- we don't have enough type context with a cast, so we default to text + NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) + Identifier i -> + AttributeAtomExpr <$> convertQualifiedName i + BinaryOperator exprA qn exprB -> do + a <- convertScalarExpr typeF exprA + b <- convertScalarExpr typeF exprB + f <- lookupFunc qn + pure $ f [a,b] + +convertProjectionScalarExpr :: TypeForRelExprF -> ProjectionScalarExpr -> Either SQLError AtomExpr +convertProjectionScalarExpr typeF expr = do + let naked = pure . NakedAtomExpr + case expr of + IntegerLiteral i -> naked (IntegerAtom i) + DoubleLiteral d -> naked (DoubleAtom d) + StringLiteral s -> naked (TextAtom s) + NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) + Identifier i -> + AttributeAtomExpr <$> convertQualifiedProjectionName i + BinaryOperator exprA qn exprB -> do + a <- convertProjectionScalarExpr typeF exprA + b <- convertProjectionScalarExpr typeF exprB + f <- lookupFunc qn + pure $ f [a,b] + +convertOrderByClause :: TypeForRelExprF -> [SortExpr] -> Either SQLError [AttributeOrderExpr] +convertOrderByClause typeF exprs = + mapM converter exprs + where + converter (SortExpr sexpr mDirection mNullsOrder) = do + atomExpr <- convertScalarExpr typeF sexpr + attrn <- case atomExpr of + AttributeAtomExpr aname -> pure aname + x -> Left (NotSupportedError (T.pack (show x))) + let ordering = case mDirection of + Nothing -> AscendingOrder + Just Ascending -> AscendingOrder + Just Descending -> DescendingOrder + case mNullsOrder of + Nothing -> pure () + Just x -> Left (NotSupportedError (T.pack (show x))) + pure (AttributeOrderExpr attrn ordering) + + +convertWithClause :: TypeForRelExprF -> WithClause -> Either SQLError WithNamesAssocs +convertWithClause = undefined + +type ColumnRemap = M.Map QualifiedName QualifiedName + +convertFromClause :: TypeForRelExprF -> [TableRef] -> Either SQLError (RelationalExpr, TableContext, ColumnRemap) +convertFromClause typeF (firstRef:trefs) = do + --the first table ref must be a straight RelationVariable + let convertFirstTableRef (SimpleTableRef qn@(QualifiedName [nam])) = do + let rv = RelationVariable nam () + typeR <- wrapTypeF typeF rv + let tContext = TableContext (M.singleton qn (rv, attributes typeR)) + pure (rv, tContext) -- include with clause even for simple cases because we use this mapping to columns to tables + convertFirstTableRef (AliasedTableRef tref (AliasName alias)) = do + (rvExpr, TableContext tContext) <- convertFirstTableRef tref + (rvExpr', tContext') <- case rvExpr of + RelationVariable oldName () -> + let origQn = QualifiedName [oldName] in + case M.lookup origQn tContext of + Just res -> pure $ (RelationVariable alias (), + M.delete origQn (M.insert (QualifiedName [alias]) res tContext)) + Nothing -> Left (MissingTableReferenceError origQn) + other -> Left (UnexpectedRelationalExprError other) + pure (rvExpr', TableContext tContext') + (firstRel, tableAliases) <- convertFirstTableRef firstRef + (expr', tContext'') <- foldM (joinTableRef typeF) (firstRel, tableAliases) (zip [1..] trefs) + pure (expr', tContext'', mempty {- FIXME add column remapping-}) + +-- | Convert TableRefs after the first one (assumes all additional TableRefs are for joins). +convertTableRef :: TypeForRelExprF -> TableContext -> TableRef -> Either SQLError (QualifiedName, RelationalExpr, TableContext) +convertTableRef typeF tableContext tref = + case tref of + SimpleTableRef qn@(QualifiedName [nam]) -> do + let rv = RelationVariable nam () + typeRel <- wrapTypeF typeF rv + tContext' <- insertTable qn rv (attributes typeRel) tableContext + pure (qn, rv, tContext') -- include with clause even for simple cases because we use this mapping to + AliasedTableRef (SimpleTableRef qn@(QualifiedName [nam])) (AliasName newName) -> do + traceShowM ("aliased", nam, newName) + typeRel <- wrapTypeF typeF (RelationVariable nam ()) + let rv = RelationVariable newName () + newKey = QualifiedName [newName] + tContext' <- insertTable newKey rv (attributes typeRel) tableContext + pure $ (newKey, RelationVariable nam (), tContext') + x -> Left $ NotSupportedError (T.pack (show x)) + + +joinTableRef :: TypeForRelExprF -> (RelationalExpr, TableContext) -> (Int, TableRef) -> Either SQLError (RelationalExpr, TableContext) +joinTableRef typeF (rvA, tcontext) (c,tref) = do + let attrRenamer x expr attrs = do + renamed <- mapM (renameOneAttr x expr) attrs + pure (Rename (S.fromList renamed) expr) + renameOneAttr x expr old_name = pure (old_name, new_name) + where + new_name = T.concat [prefix, ".", old_name] + prefix = case expr of + RelationVariable rvName () -> rvName + _ -> x -- probably need to return errors for some expressions + case tref of + NaturalJoinTableRef jtref -> do + -- then natural join is the only type of join which the relational algebra supports natively + (_, rvB, tcontext') <- convertTableRef typeF tcontext jtref + pure $ (Join rvA rvB, tcontext') + CrossJoinTableRef jtref -> do + --rename all columns to prefix them with a generated alias to prevent any natural join occurring, then perform normal join + -- we need the type to get all the attribute names for both relexprs + (tKey, rvB, tcontext'@(TableContext tmap')) <- convertTableRef typeF tcontext jtref + traceShowM ("jointref", rvB, tmap') + case typeF rvA of + Left err -> Left (SQLRelationalError err) + Right typeA -> + case typeF rvB of + Left err -> Left (SQLRelationalError err) + Right typeB -> do + let attrsA = A.attributeNameSet (attributes typeA) + attrsB = A.attributeNameSet (attributes typeB) + attrsIntersection = S.intersection attrsA attrsB + --find intersection of attributes and rename all of them with prefix 'expr'+c+'.' + exprA <- attrRenamer "a" rvA (S.toList attrsIntersection) + pure (Join exprA rvB, tcontext') + InnerJoinTableRef jtref (JoinUsing qnames) -> do + (_, rvB, tcontext') <- convertTableRef typeF tcontext jtref + let jCondAttrs = S.fromList $ map convertUnqualifiedName qnames + (attrsIntersection, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB + --rename attributes used in the join condition + let attrsToRename = S.difference attrsIntersection jCondAttrs +-- traceShowM ("inner", attrsToRename, attrsIntersection, jCondAttrs) + exprA <- attrRenamer "a" rvA (S.toList attrsToRename) + pure (Join exprA rvB, tcontext') + + InnerJoinTableRef jtref (JoinOn (JoinOnCondition joinExpr)) -> do + --create a cross join but extend with the boolean sexpr + --extend the table with the join conditions, then join on those + --exception: for simple attribute equality, use regular join renames using JoinOn logic + + (tKey, rvB, tContext'@(TableContext allAliases)) <- convertTableRef typeF tcontext jtref + --rvA and rvB now reference potentially aliased relation variables (needs with clause to execute), but this is useful for making attributes rv-prefixed +-- traceShowM ("converted", rvA, rvB, tAliases) + --extract all table aliases to create a remapping for SQL names discovered in the sexpr + withExpr <- With <$> tableAliasesAsWithNameAssocs tContext' + (commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF (withExpr rvA) (withExpr rvB) + -- first, execute the rename, renaming all attributes according to their table aliases + let rvPrefix rvExpr = + case rvExpr of + RelationVariable nam () -> pure nam + x -> Left $ NotSupportedError ("cannot derived name for relational expression " <> T.pack (show x)) + rvPrefixA <- rvPrefix rvA + rvPrefixB <- rvPrefix rvB + exprA <- attrRenamer rvPrefixA rvA (S.toList attrsA) + exprB <- attrRenamer rvPrefixB rvB (S.toList attrsB) + -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition + let joinExpr' = renameIdentifier renamer joinExpr + renamer n@(QualifiedName [tableAlias,attr]) = --lookup prefixed with table alias + case M.lookup n allAliases of + -- the table was not renamed, but the attribute may have been renamed + -- find the source of the attribute + Nothing -> n + Just found -> error (show (tableAlias, found)) + renamer n@(QualifiedName [attr]) = error (show n) + joinRe <- convertScalarExpr typeF joinExpr' + --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name = + --rename all common attrs and use the new names in the join condition + let allAttrs = S.union attrsA attrsB + firstAvailableName c allAttrs' = + let new_name = T.pack ("join_" <> show c) in + if S.member new_name allAttrs' then + firstAvailableName (c + 1) allAttrs' + else + new_name + joinName = firstAvailableName 1 allAttrs + extender = AttributeExtendTupleExpr joinName joinRe + joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) + projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) + pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA))), tContext') + +convertUnqualifiedName :: UnqualifiedName -> AttributeName +convertUnqualifiedName (UnqualifiedName t) = t + +-- this could be amended to support more complex expressions such as coalesce by returning an [AtomExpr] -> AtomExpr function +lookupFunc :: QualifiedName -> Either SQLError ([AtomExpr] -> AtomExpr) +lookupFunc qname = + case qname of + QualifiedName [nam] -> + case lookup nam sqlFuncs of + Nothing -> Left $ NoSuchSQLFunctionError qname + Just match -> pure match + where + f n args = FunctionAtomExpr n args () + sqlFuncs = [(">",f "gt"), + ("<",f "lt"), + (">=",f "gte"), + ("<=",f "lte"), + ("=",f "eq"), + ("!=",f "not_eq"), -- function missing + ("<>",f "not_eq"), -- function missing + ("+", f "add"), + ("and", f "and"), + ("or", f "or") + ] + +-- | Used in join condition detection necessary for renames to enable natural joins. +commonAttributeNames :: TypeForRelExprF -> RelationalExpr -> RelationalExpr -> Either SQLError (S.Set AttributeName, S.Set AttributeName, S.Set AttributeName) +commonAttributeNames typeF rvA rvB = + case typeF rvA of + Left err -> Left (SQLRelationalError err) + Right typeA -> + case typeF rvB of + Left err -> Left (SQLRelationalError err) + Right typeB -> do + let attrsA = A.attributeNameSet (attributes typeA) + attrsB = A.attributeNameSet (attributes typeB) + pure $ (S.intersection attrsA attrsB, attrsA, attrsB) + + ------------------------------------------------ +{- class SQLConvert sqlexpr where type ConverterF sqlexpr :: Type convert :: TypeForRelExprF -> sqlexpr -> Either SQLError (ConverterF sqlexpr) @@ -37,6 +537,7 @@ class SQLConvert sqlexpr where instance SQLConvert Select where type ConverterF Select = DataFrameExpr convert typeF sel = do + --new strategy- rename all attributes by default and keep a mapping of discovered attributes. At the end of conversion, if there is no overlap in base attribute names, remove the table alias prefixes. projF <- convert typeF (projectionClause sel) -- we have explicit with clauses written by the user, but also our own implementation-specific with expressions explicitWithF <- case withClause sel of @@ -45,12 +546,12 @@ instance SQLConvert Select where wExprs <- convert typeF wClause pure (With wExprs) - let baseDFExpr = DataFrameExpr { convertExpr = ExistingRelation relationTrue, + let baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () []), orderExprs = [], offset = Nothing, limit = Nothing } case tableExpr sel of - Nothing -> pure baseDFExpr + Nothing -> Just tExpr -> do (dfExpr, withNames) <- convert typeF tExpr let withF = case withNames of @@ -59,21 +560,6 @@ instance SQLConvert Select where pure (dfExpr { convertExpr = explicitWithF (withF (projF (convertExpr dfExpr))) }) -tableAliasesAsWithNameAssocs :: TableAliasMap -> Either SQLError WithNamesAssocs -tableAliasesAsWithNameAssocs tmap = - filter notSelfRef <$> mapM mapper (M.toList tmap) - where - notSelfRef (WithNameExpr nam (), RelationVariable nam' ()) | nam == nam' = False - | otherwise = True - notSelfRef _ = True - mapper (QualifiedName [nam], rvExpr) = pure (WithNameExpr nam (), rvExpr) - mapper (qn, _) = Left (NotSupportedError ("schema qualified table names: " <> T.pack (show qn))) - -data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set QualifiedProjectionName, - taskRenames :: [(QualifiedProjectionName, AliasName)], - taskExtenders :: [ExtendTupleExpr] - } deriving (Show, Eq) - instance SQLConvert [SelectItem] where type ConverterF [SelectItem] = (RelationalExpr -> RelationalExpr) convert typeF selItems = do @@ -128,7 +614,7 @@ instance SQLConvert [SelectItem] where let attrsProj = A.some (map (\rv -> RelationalExprAttributeNames (RelationVariable rv ())) relExprRvs <> [AttributeNames attrNames]) pure $ Project attrsProj -- apply extensions - let fExtended = foldl' (\acc ext -> (Extend ext) . acc) id (taskExtenders task) + let fExtended = foldr (\ext acc -> (Extend ext) . acc) id (taskExtenders task) -- apply rename renamesSet <- foldM (\acc (qProjName, (AliasName newName)) -> do oldName <- convert typeF qProjName @@ -140,6 +626,10 @@ instance SQLConvert TableExpr where --pass with exprs up because they must be applied after applying projections type ConverterF TableExpr = (DataFrameExpr, WithNamesAssocs) convert typeF tExpr = do + let renameAllAttrs = case whereClause tExpr of + Nothing -> False + Just wClause -> needsToRenameAllAttributes wClause + (fromExpr, tableAliasMap) <- convert typeF (fromClause tExpr) let tableAliasMap' = M.filterWithKey filterRedundantAlias tableAliasMap filterRedundantAlias (QualifiedName [nam]) (RelationVariable nam' ()) @@ -148,6 +638,8 @@ instance SQLConvert TableExpr where withExprs <- mapM (\(qnam, expr) -> do nam <- convert typeF qnam pure (WithNameExpr nam (), expr)) (M.toList tableAliasMap') + + expr' <- case whereClause tExpr of Just whereExpr -> do restrictPredExpr <- convert typeF whereExpr @@ -263,9 +755,7 @@ instance SQLConvert [TableRef] where Nothing -> n Just found -> error (show (tableAlias, found)) renamer n@(QualifiedName [attr]) = error (show n) - traceShowM ("joinExpr'", joinExpr') joinRe <- convert typeF joinExpr' - traceShowM ("joinRe", joinRe) --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name = --rename all common attrs and use the new names in the join condition let allAttrs = S.union attrsA attrsB @@ -298,14 +788,6 @@ commonAttributeNames typeF rvA rvB = pure $ (S.intersection attrsA attrsB, attrsA, attrsB) ---over the course of conversion, we collect all the table aliases we encounter, including non-aliased table references -type TableAliasMap = M.Map QualifiedName RelationalExpr - -insertTableAlias :: QualifiedName -> RelationalExpr -> TableAliasMap -> Either SQLError TableAliasMap -insertTableAlias qn expr map' = - case M.lookup qn map' of - Nothing -> pure $ M.insert qn expr map' - Just _ -> Left (DuplicateTableReferenceError qn) -- convert a TableRef in isolation- to be used with the first TableRef only instance SQLConvert TableRef where @@ -347,34 +829,20 @@ instance SQLConvert RestrictionExpr where folder predExpr'' sexprItem = do item <- convert typeF sexprItem pure $ OrPredicate (inFunc eqExpr item) predExpr'' - res <- foldM folder predExpr' matches --be careful here once we introduce NULLs + res <- foldM folder predExpr' matches --be careful here once we introduce NULLs case inOrNotIn of In -> pure res NotIn -> pure (NotPredicate res) + ExistsExpr subQ -> do + dfExpr <- convert typeF subQ + --pretty sure I have to rename attributes in both the top-level query and in this one to prevent attribute conflicts- we can't rename all the attributes in the subquery, because the renamer won't know which attributes actually refer to the top-level attributes- should we just prefix all attributes unconditionally or send a signal upstream to rename attributes? + when (usesDataFrameFeatures dfExpr) $ Left (NotSupportedError "ORDER BY/LIMIT/OFFSET in EXISTS subquery") + let rexpr = Equals (Project A.empty (convertExpr dfExpr)) (RelationVariable "true" ()) + pure (RelationalExprPredicate rexpr) + - --- this could be amended to support more complex expressions such as coalesce by returning an [AtomExpr] -> AtomExpr function -lookupFunc :: QualifiedName -> Either SQLError ([AtomExpr] -> AtomExpr) -lookupFunc qname = - case qname of - QualifiedName [nam] -> - case lookup nam sqlFuncs of - Nothing -> Left $ NoSuchSQLFunctionError qname - Just match -> pure match - where - f n args = FunctionAtomExpr n args () - sqlFuncs = [(">",f "gt"), - ("<",f "lt"), - (">=",f "gte"), - ("<=",f "lte"), - ("=",f "eq"), - ("!=",f "not_eq"), -- function missing - ("<>",f "not_eq"), -- function missing - ("+", f "add"), - ("and", f "and"), - ("or", f "or") - ] - +-} +{- instance SQLConvert ScalarExpr where type ConverterF ScalarExpr = AtomExpr convert typeF expr = do @@ -383,6 +851,8 @@ instance SQLConvert ScalarExpr where IntegerLiteral i -> naked (IntegerAtom i) DoubleLiteral d -> naked (DoubleAtom d) StringLiteral s -> naked (TextAtom s) + -- we don't have enough type context with a cast, so we default to text + NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) Identifier i -> AttributeAtomExpr <$> convert typeF i BinaryOperator exprA qn exprB -> do @@ -390,6 +860,7 @@ instance SQLConvert ScalarExpr where b <- convert typeF exprB f <- lookupFunc qn pure $ f [a,b] + -- PrefixOperator qn expr -> do @@ -407,6 +878,7 @@ instance SQLConvert ProjectionScalarExpr where IntegerLiteral i -> naked (IntegerAtom i) DoubleLiteral d -> naked (DoubleAtom d) StringLiteral s -> naked (TextAtom s) + NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) Identifier i -> AttributeAtomExpr <$> convert typeF i BinaryOperator exprA qn exprB -> do @@ -442,7 +914,7 @@ instance SQLConvert WithClause where pure (WithNameExpr nam (), (convertExpr dfExpr)) -- if the subquery is a Select, how do I get a rvexpr out of it rather than a data frame- perhaps a different conversion function? mapM mapper (NE.toList ctes) - +-} -- | Used to remap SQL qualified names to new names to prevent conflicts in join conditions. renameIdentifier :: (QualifiedName -> QualifiedName) -> ScalarExpr -> ScalarExpr @@ -452,3 +924,26 @@ renameIdentifier renamer sexpr = Fold.cata renamer' sexpr renamer' (IdentifierF n) = Identifier (renamer n) renamer' x = Fold.embed x +-- | If the restriction includes a EXISTS expression, we must rename all attributes at the top-level to prevent conflicts. +needsToRenameAllAttributes :: RestrictionExpr -> Bool +needsToRenameAllAttributes (RestrictionExpr sexpr) = + rec' sexpr + where + rec' sexpr' = + case sexpr' of + DoubleLiteral{} -> False + StringLiteral{} -> False + NullLiteral{} -> False + Identifier{} -> False + BinaryOperator e1 _ e2 -> rec' e1 || rec' e2 + PrefixOperator _ e1 -> rec' e1 + PostfixOperator e1 _ -> rec' e1 + BetweenOperator e1 _ e2 -> rec' e1 || rec' e2 + FunctionApplication _ e1 -> rec' e1 + CaseExpr cases else' -> or (map (\(whens, then') -> + or (map rec' whens) || rec' then') cases) + qc@QuantifiedComparison{} -> True + InExpr _ sexpr _ -> rec' sexpr + BooleanOperatorExpr e1 _ e2 -> rec' e1 || rec' e2 + ExistsExpr{} -> True + diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 59cab0b9..f1c752e5 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -60,6 +60,7 @@ data ScalarExprBase n = IntegerLiteral Integer | DoubleLiteral Double | StringLiteral Text + | NullLiteral -- | Interval | Identifier n | BinaryOperator (ScalarExprBase n) QualifiedName (ScalarExprBase n) @@ -69,7 +70,7 @@ data ScalarExprBase n = | FunctionApplication QualifiedName (ScalarExprBase n) | CaseExpr { caseWhens :: [([ScalarExprBase n],ScalarExprBase n)], caseElse :: Maybe (ScalarExprBase n) } - | QuantifiedComparison { qcExpr :: (ScalarExprBase n), + | QuantifiedComparison { qcExpr :: ScalarExprBase n, qcOperator :: ComparisonOperator, qcPredicate :: QuantifiedComparisonPredicate, qcQuery :: Select } @@ -79,6 +80,7 @@ data ScalarExprBase n = -- | UniqueSubQuery Select -- | ScalarSubQuery Select | BooleanOperatorExpr (ScalarExprBase n) BoolOp (ScalarExprBase n) + | ExistsExpr Select deriving (Show, Eq) data BoolOp = AndOp | OrOp @@ -352,7 +354,7 @@ comparisonOperatorP = choice (map (\(match', op) -> reserved match' $> op) ops) ("!=", OpNE)] simpleLiteralP :: Parser (ScalarExprBase a) -simpleLiteralP = try doubleLiteralP <|> integerLiteralP <|> stringLiteralP +simpleLiteralP = try doubleLiteralP <|> integerLiteralP <|> stringLiteralP <|> nullLiteralP doubleLiteralP :: Parser (ScalarExprBase a) doubleLiteralP = DoubleLiteral <$> double @@ -373,18 +375,30 @@ stringLiteralP = StringLiteral <$> stringP pure $ T.concat [capture, "'",rest]), --quoted quote pure capture ] + +nullLiteralP :: Parser (ScalarExprBase a) +nullLiteralP = + reserved "NULL" *> pure NullLiteral scalarTermP :: QualifiedNameP a => Parser (ScalarExprBase a) scalarTermP = choice [ + existsP, simpleLiteralP, --,subQueryExpr -- caseExpr, --,cast -- subquery, -- pseudoArgFunc, -- includes NOW, NOW(), CURRENT_USER, TRIM(...), etc. - Identifier <$> qualifiedNameP] + Identifier <$> qualifiedNameP + ] "scalar expression" + +existsP :: Parser (ScalarExprBase a) +existsP = do + reserved "exists" + ExistsExpr <$> parens selectP + -- used to distinguish between sections which may include an asterisk and those which cannot class QualifiedNameP a where qualifiedNameP :: Parser a diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index d191252a..e76907ad 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -26,19 +26,19 @@ testSelect = TestCase $ do (tgraph,transId) <- freshTransactionGraph dateExamples let readTests = [ -- simple relvar - ("SELECT * FROM test", "(test)"), + ("SELECT * FROM s", "(s)"), -- simple projection - ("SELECT a FROM test", "(test{a})"), + ("SELECT city FROM s", "(s{city})"), -- restriction - ("SELECT a FROM test where b=3","((test where b=3){a})"), + ("SELECT city FROM s where status=20","((s where status=20){city})"), -- restriction - ("SELECT a,b FROM test where b>3","((test where gt(@b,3)){a,b})"), + ("SELECT status,city FROM s where status>20","((s where gt(@status,20)){status,city})"), -- extension mixed with projection - ("SELECT a,b,10 FROM test","((test:{attr_3:=10}){a,b,attr_3})"), + ("SELECT city,status,10 FROM s","((s:{attr_3:=10}){city,status,attr_3})"), -- column alias - ("SELECT a AS x FROM test","((test rename {a as x}){x})"), + ("SELECT city AS x FROM s","((s rename {city as x}){x})"), -- case insensitivity - ("sElECt A aS X FRoM TeST","((test rename {a as x}){x})"), + ("sElECt CitY aS X FRoM s","((s rename {city as x}){x})"), --column from aliased table ("SELECT sup.city FROM s AS sup","(with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`}))"), --projection with alias @@ -49,10 +49,10 @@ testSelect = TestCase $ do -- cross join ("SELECT * FROM s CROSS JOIN sp", "((s rename {s# as `s.s#`}) join sp)"), -- unaliased join using - ("SELECT * FROM sp INNER JOIN sp USING (\"s#\")", + ("SELECT * FROM sp INNER JOIN sp AS sp2 USING (\"s#\")", "((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join sp)"), -- unaliased join - ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1})"), + ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1})"){-, -- aliased join on ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#", "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})"), @@ -72,11 +72,15 @@ testSelect = TestCase $ do ("SELECT * FROM s WHERE s# NOT IN ('S1','S2')", "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))"), -- where exists - --("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE s.s#=sp.s#)","s"), + ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s.s#\"=\"sp.s#\")","((s rename {s# as `s.s#`}) where ((sp rename {s# as `sp.s#`}) where s#))"), -- where not exists -- group by -- group by having -- limit + -- case when + -- union + -- intersect + -- except ("SELECT * FROM s LIMIT 10","(s) limit 10"), -- offset ("SELECT * FROM s OFFSET 10","(s) offset 10"), @@ -87,7 +91,11 @@ testSelect = TestCase $ do -- order by descending ("SELECT * FROM s ORDER BY status DESC,city","(s) orderby {status descending,city}"), -- CTEs - ("WITH x AS (SELECT * FROM s) SELECT * FROM x", "(with (x as s) x)") + ("WITH x AS (SELECT * FROM s) SELECT * FROM x", "(with (x as s) x)"), + -- SELECT with no table expression + ("SELECT 1,2,3","((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})"), + -- basic NULL + ("SELECT NULL", "((relation{}{}:{attr_1:=Nothing}){attr_1})")-} ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, @@ -97,12 +105,12 @@ testSelect = TestCase $ do let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr) runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) check (sql, tutd) = do - --print sql + print sql --parse SQL select <- case parse (queryExprP <* eof) "test" sql of Left err -> error (errorBundlePretty err) Right x -> do - print x + --print x pure x --parse tutd relExpr <- case parse (dataFrameP <* eof) "test" tutd of @@ -110,7 +118,7 @@ testSelect = TestCase $ do Right x -> do --print x pure x - selectAsRelExpr <- case convert typeF select of + selectAsRelExpr <- case convertSelect typeF select of Left err -> error (show err) Right x -> do pure x From c2f083b5093c895cc3b83366a91570d9eddd5e73 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 28 Aug 2023 00:29:40 -0400 Subject: [PATCH 016/170] WIP fix aliased join --- src/bin/SQL/Interpreter/Convert.hs | 31 ++++++++++++++++++++---------- test/SQL/InterpreterTest.hs | 7 ++++--- 2 files changed, 25 insertions(+), 13 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 0ad34f2c..6819c8a8 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -27,6 +27,7 @@ data SQLError = NotSupportedError T.Text | NoSuchSQLFunctionError QualifiedName | DuplicateTableReferenceError QualifiedName | MissingTableReferenceError QualifiedName | + UnexpectedQualifiedNameError QualifiedName | ColumnResolutionError QualifiedName | UnexpectedRelationalExprError RelationalExpr | AmbiguousColumnResolutionError QualifiedName | @@ -145,7 +146,6 @@ convertSelect typeF sel = do -- convert projection using table alias map to resolve column names projF <- convertProjection typeF tAliasMap (projectionClause sel) -- add with clauses - withAssocs <- tableAliasesAsWithNameAssocs tAliasMap let withF = case withAssocs of [] -> id @@ -383,7 +383,7 @@ convertFromClause typeF (firstRef:trefs) = do (expr', tContext'') <- foldM (joinTableRef typeF) (firstRel, tableAliases) (zip [1..] trefs) pure (expr', tContext'', mempty {- FIXME add column remapping-}) --- | Convert TableRefs after the first one (assumes all additional TableRefs are for joins). +-- | Convert TableRefs after the first one (assumes all additional TableRefs are for joins). Returns the qualified name key that was added to the map, the underlying relexpr (not aliased so that it can used for extracting type information), and the new table context map convertTableRef :: TypeForRelExprF -> TableContext -> TableRef -> Either SQLError (QualifiedName, RelationalExpr, TableContext) convertTableRef typeF tableContext tref = case tref of @@ -393,9 +393,8 @@ convertTableRef typeF tableContext tref = tContext' <- insertTable qn rv (attributes typeRel) tableContext pure (qn, rv, tContext') -- include with clause even for simple cases because we use this mapping to AliasedTableRef (SimpleTableRef qn@(QualifiedName [nam])) (AliasName newName) -> do - traceShowM ("aliased", nam, newName) typeRel <- wrapTypeF typeF (RelationVariable nam ()) - let rv = RelationVariable newName () + let rv = RelationVariable nam () newKey = QualifiedName [newName] tContext' <- insertTable newKey rv (attributes typeRel) tableContext pure $ (newKey, RelationVariable nam (), tContext') @@ -404,9 +403,18 @@ convertTableRef typeF tableContext tref = joinTableRef :: TypeForRelExprF -> (RelationalExpr, TableContext) -> (Int, TableRef) -> Either SQLError (RelationalExpr, TableContext) joinTableRef typeF (rvA, tcontext) (c,tref) = do + -- optionally prefix attributes unelss the expr is a RelationVariable let attrRenamer x expr attrs = do renamed <- mapM (renameOneAttr x expr) attrs + traceShowM ("attrRenamer", renamed) + pure (Rename (S.fromList renamed) expr) + -- prefix all attributes + prefixRenamer prefix expr attrs = do + renamed <- mapM (prefixOneAttr prefix) attrs pure (Rename (S.fromList renamed) expr) + prefixOneAttr prefix old_name = pure (old_name, new_name) + where + new_name = T.concat [prefix, ".", old_name] renameOneAttr x expr old_name = pure (old_name, new_name) where new_name = T.concat [prefix, ".", old_name] @@ -422,7 +430,6 @@ joinTableRef typeF (rvA, tcontext) (c,tref) = do --rename all columns to prefix them with a generated alias to prevent any natural join occurring, then perform normal join -- we need the type to get all the attribute names for both relexprs (tKey, rvB, tcontext'@(TableContext tmap')) <- convertTableRef typeF tcontext jtref - traceShowM ("jointref", rvB, tmap') case typeF rvA of Left err -> Left (SQLRelationalError err) Right typeA -> @@ -454,6 +461,7 @@ joinTableRef typeF (rvA, tcontext) (c,tref) = do --rvA and rvB now reference potentially aliased relation variables (needs with clause to execute), but this is useful for making attributes rv-prefixed -- traceShowM ("converted", rvA, rvB, tAliases) --extract all table aliases to create a remapping for SQL names discovered in the sexpr + withExpr <- With <$> tableAliasesAsWithNameAssocs tContext' (commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF (withExpr rvA) (withExpr rvB) -- first, execute the rename, renaming all attributes according to their table aliases @@ -461,14 +469,17 @@ joinTableRef typeF (rvA, tcontext) (c,tref) = do case rvExpr of RelationVariable nam () -> pure nam x -> Left $ NotSupportedError ("cannot derived name for relational expression " <> T.pack (show x)) - rvPrefixA <- rvPrefix rvA - rvPrefixB <- rvPrefix rvB - exprA <- attrRenamer rvPrefixA rvA (S.toList attrsA) - exprB <- attrRenamer rvPrefixB rvB (S.toList attrsB) + rvNameB <- case tKey of -- could be original relvar name or an alias whereas rvB is the unaliased name + QualifiedName [nam] -> pure nam + other -> Left (UnexpectedQualifiedNameError other) + rvNameA <- rvPrefix rvA +-- rvPrefixB <- rvPrefix rvB + exprA <- prefixRenamer rvNameA rvA (S.toList attrsA) + exprB <- prefixRenamer rvNameB (RelationVariable rvNameB ()) (S.toList attrsB) -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition let joinExpr' = renameIdentifier renamer joinExpr renamer n@(QualifiedName [tableAlias,attr]) = --lookup prefixed with table alias - case M.lookup n allAliases of + case traceShow ("renamer", n) $ M.lookup n allAliases of -- the table was not renamed, but the attribute may have been renamed -- find the source of the attribute Nothing -> n diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index e76907ad..1efd5318 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -24,7 +24,7 @@ testSelect :: Test testSelect = TestCase $ do -- check that SQL and tutd compile to same thing (tgraph,transId) <- freshTransactionGraph dateExamples - let readTests = [ + let readTests = [{- -- simple relvar ("SELECT * FROM s", "(s)"), -- simple projection @@ -52,10 +52,10 @@ testSelect = TestCase $ do ("SELECT * FROM sp INNER JOIN sp AS sp2 USING (\"s#\")", "((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join sp)"), -- unaliased join - ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1})"){-, + ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1})"),-} -- aliased join on ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#", - "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})"), + "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})"){-, -- formula extension ("SELECT status+10 FROM s", "((s : {attr_1:=add(@status,10)}) { attr_1 })"), -- extension and formula @@ -121,6 +121,7 @@ testSelect = TestCase $ do selectAsRelExpr <- case convertSelect typeF select of Left err -> error (show err) Right x -> do + print x pure x --print ("selectAsRelExpr"::String, selectAsRelExpr) From 5c71df724dda141428874e891d1b8a45fe34b24d Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 24 Sep 2023 14:52:22 -0400 Subject: [PATCH 017/170] wip: compilation checkpoint after QualifiedName replacement with ColumnName, TableName, etc. to disambiguate the types columnname conversion is wrong --- src/bin/SQL/Interpreter/Base.hs | 2 +- src/bin/SQL/Interpreter/Convert.hs | 778 +++++++++-------------------- src/bin/SQL/Interpreter/Select.hs | 99 ++-- test/SQL/InterpreterTest.hs | 62 ++- 4 files changed, 356 insertions(+), 585 deletions(-) diff --git a/src/bin/SQL/Interpreter/Base.hs b/src/bin/SQL/Interpreter/Base.hs index 8888c5b7..7b921088 100644 --- a/src/bin/SQL/Interpreter/Base.hs +++ b/src/bin/SQL/Interpreter/Base.hs @@ -27,7 +27,7 @@ reserveds words' = do -- does not consume trailing spaces qualifiedNameSegment :: Text -> Parser Text -qualifiedNameSegment sym = T.toLower <$> string' sym +qualifiedNameSegment sym = T.toLower <$> string' sym reservedOp :: Text -> Parser () reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 6819c8a8..573c7c13 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -19,32 +19,41 @@ import qualified Data.Functor.Foldable as Fold import qualified Data.List.NonEmpty as NE import Control.Monad (when) import ProjectM36.DataTypes.Maybe +import Control.Monad (void) +import Data.Maybe (fromMaybe) import Debug.Trace data SQLError = NotSupportedError T.Text | TypeMismatchError AtomType AtomType | - NoSuchSQLFunctionError QualifiedName | - DuplicateTableReferenceError QualifiedName | - MissingTableReferenceError QualifiedName | - UnexpectedQualifiedNameError QualifiedName | - ColumnResolutionError QualifiedName | + NoSuchSQLFunctionError FuncName | + DuplicateTableReferenceError TableAlias | + MissingTableReferenceError TableAlias | + UnexpectedTableNameError TableName | + UnexpectedColumnNameError ColumnName | + ColumnResolutionError ColumnName | UnexpectedRelationalExprError RelationalExpr | - AmbiguousColumnResolutionError QualifiedName | + UnexpectedAsteriskError ColumnProjectionName | + AmbiguousColumnResolutionError ColumnName | + DuplicateColumnAliasError ColumnAlias | SQLRelationalError RelationalError deriving (Show, Eq) type TypeForRelExprF = RelationalExpr -> Either RelationalError Relation -data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set QualifiedProjectionName, - taskRenames :: [(QualifiedProjectionName, AliasName)], +--type ConvertM = State + +data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set ColumnProjectionName, + taskRenames :: [(ColumnProjectionName, ColumnAlias)], taskExtenders :: [ExtendTupleExpr] } deriving (Show, Eq) --over the course of conversion, we collect all the table aliases we encounter, including non-aliased table references, including the type of the table -newtype TableContext = TableContext (M.Map QualifiedName (RelationalExpr, Attributes)) +newtype TableContext = TableContext (M.Map TableAlias (RelationalExpr, Attributes, ColumnAliasMap)) deriving (Semigroup, Monoid, Show, Eq) - + +-- key: alias value: real column attribute name +type ColumnAliasMap = M.Map ColumnAlias AttributeName tableAliasesAsWithNameAssocs :: TableContext -> Either SQLError WithNamesAssocs tableAliasesAsWithNameAssocs (TableContext tmap) = @@ -53,48 +62,96 @@ tableAliasesAsWithNameAssocs (TableContext tmap) = notSelfRef (WithNameExpr nam (), RelationVariable nam' ()) | nam == nam' = False | otherwise = True notSelfRef _ = True - mapper :: (QualifiedName, (RelationalExpr, Attributes)) -> Either SQLError (WithNameExpr, RelationalExpr) - mapper (QualifiedName [nam], (rvExpr, _)) = pure (WithNameExpr nam (), rvExpr) +-- mapper :: (QualifiedName, (RelationalExpr, Attributes, _)) -> Either SQLError (WithNameExpr, RelationalExpr) + mapper (TableAlias nam, (rvExpr, _, _)) = pure (WithNameExpr nam (), rvExpr) mapper (qn, _) = Left (NotSupportedError ("schema qualified table names: " <> T.pack (show qn))) -- | Insert another table into the TableContext. -insertTable :: QualifiedName -> RelationalExpr -> Attributes -> TableContext -> Either SQLError TableContext -insertTable qn expr rtype (TableContext map') = - case M.lookup qn map' of - Nothing -> pure $ TableContext $ M.insert qn (expr, rtype) map' - Just _ -> Left (DuplicateTableReferenceError qn) - -lookupTable :: QualifiedName -> TableContext -> Either SQLError (RelationalExpr, Attributes) -lookupTable qn (TableContext map') = - case M.lookup qn map' of - Nothing -> Left (MissingTableReferenceError qn) +insertTable :: TableAlias -> RelationalExpr -> Attributes -> TableContext -> Either SQLError TableContext +insertTable tAlias expr rtype (TableContext map') = + case M.lookup tAlias map' of + Nothing -> pure $ TableContext $ M.insert tAlias (expr, rtype, mempty) map' + Just _ -> Left (DuplicateTableReferenceError tAlias) + +-- | When a column is mentioned, it may need to be aliased. The table name must already be in the table context so that we can identify that the attribute exists. Without a table name, we must look for a uniquely named column amongst all tables. +insertColumn :: Maybe TableAlias -> ColumnName -> Maybe ColumnAlias -> TableContext -> Either SQLError (TableContext, ColumnAlias) +insertColumn mTblAlias colName mColAlias tcontext@(TableContext tmap) = do + -- find the relevant table for the key to the right table + tblAlias' <- case mTblAlias of + Just tblAlias -> do + void $ lookupTable tblAlias tcontext + pure tblAlias + Nothing -> + -- scan column names for match- if there are multiple matches, return a column ambiguity error + findOneColumn colName tcontext + -- insert into the column alias map + let newAlias = case mColAlias of + Nothing -> case colName of + ColumnName [c] -> ColumnAlias c + ColumnName [_,c] -> ColumnAlias c + Just al -> al + origColName = case colName of + ColumnName [c] -> c + ColumnName [_,c] -> c + + when (newAlias `elem` allColumnAliases tcontext) $ Left (DuplicateColumnAliasError newAlias) + --verify that the alias is not duplicated + let tcontext' = M.adjust insertCol tblAlias' tmap + insertCol (rvexpr, attrs, colMap) = + (rvexpr, attrs, M.insert newAlias origColName colMap) + pure (TableContext tcontext', newAlias) + + +allColumnAliases :: TableContext -> [ColumnAlias] +allColumnAliases (TableContext tmap) = foldl' folder [] tmap + where + folder acc (_,_,colmap) = M.keys colmap <> acc + +lookupTable :: TableAlias -> TableContext -> Either SQLError (RelationalExpr, Attributes, ColumnAliasMap) +lookupTable ta (TableContext map') = + case M.lookup ta map' of + Nothing -> Left (MissingTableReferenceError ta) Just res -> pure res +-- | Merge table contexts (used in subselects) +insertTables :: TableContext -> TableContext -> Either SQLError TableContext +insertTables (TableContext tMapA) ctxB = + foldM folder ctxB (M.toList tMapA) + where + folder acc (qn, (re,attrs, _)) = insertTable qn re attrs acc +{- replaceTableName :: QualifiedName -> QualifiedName -> TableContext -> Either SQLError TableContext replaceTableName oldName newName (TableContext tctx) = case M.lookup oldName tctx of Nothing -> Left (MissingTableReferenceError oldName) Just match -> pure $ TableContext $ M.insert newName match (M.delete oldName tctx) - --- | Find a column name or column alias in the underlying table context. -findColumn :: QualifiedName -> TableContext -> [QualifiedName] -findColumn colName (TableContext tMap) = +-} +-- | Find a column name or column alias in the underlying table context. Returns key into table context. +findColumn :: ColumnName -> TableContext -> [TableAlias] +findColumn targetCol (TableContext tMap) = M.foldrWithKey folder [] tMap where - folder (QualifiedName [tAlias]) (rvExpr, rtype) acc = - case colName of - QualifiedName [colName'] -> + folder tAlias@(TableAlias tat) (rvExpr, rtype, _) acc = + case targetCol of + ColumnName [colName'] -> if S.member colName' (attributeNameSet rtype) then - QualifiedName [tAlias] : acc + tAlias : acc else acc - QualifiedName [tPrefix, colName'] -> - if tAlias == tPrefix && colName' == colName' then - QualifiedName [tAlias] : acc + ColumnName [tPrefix, colName'] -> + if tat == tPrefix && S.member colName' (attributeNameSet rtype) then + tAlias : acc else acc _ -> acc +findOneColumn :: ColumnName -> TableContext -> Either SQLError TableAlias +findOneColumn colName tcontext = + case findColumn colName tcontext of + [] -> Left (ColumnResolutionError colName) + [match] -> pure match + _matches -> Left (AmbiguousColumnResolutionError colName) + wrapTypeF :: TypeForRelExprF -> RelationalExpr -> Either SQLError Relation wrapTypeF typeF relExpr = case typeF relExpr of @@ -103,35 +160,38 @@ wrapTypeF typeF relExpr = -- | Return the table alias for the column name iff the attribute is unique. Used for attribute resolution. -tableAliasForColumnName :: TypeForRelExprF -> QualifiedName -> TableContext -> Either SQLError QualifiedName +{- +tableAliasForColumnName :: TypeForRelExprF -> ColumnName -> TableContext -> Either SQLError TableAlias -- the table alias is included -tableAliasForColumnName typeF qn@(QualifiedName [tAlias, _]) (TableContext tMap) = do - if M.member qn tMap then - pure (QualifiedName [tAlias]) +tableAliasForColumnName typeF cn@(ColumnName [tAlias, _]) (TableContext tMap) = do + if M.member (TableAlias tAlias) tMap then + pure (TableAlias tAlias) else - Left (ColumnResolutionError qn) -tableAliasForColumnName typeF qn@(QualifiedName [colName]) (TableContext tMap) = do + Left (ColumnResolutionError cn) +tableAliasForColumnName typeF qn@(ColumnName [colName]) (TableContext tMap) = do --look up the column name in all possible tables res <- foldM folder Nothing (M.toList tMap) case res of Just res -> pure res Nothing -> Left (ColumnResolutionError qn) where --- folder :: Maybe QualifiedName -> (QualifiedName, RelationalExpr) -> + folder :: Maybe ColumnName -> (TableAlias, RelationalExpr) -> _ folder Just{} _ = Left (AmbiguousColumnResolutionError qn) - folder Nothing (qn'@(QualifiedName [tableAlias]), (rvExpr,_)) = do + folder Nothing (TableAlias tableAlias, (rvExpr,_)) = do tRel <- wrapTypeF typeF rvExpr -- we could cache this in the table alias map ADT --traceShowM ("findColName", rvExpr, tRel) if colName `S.member` attributeNameSet (attributes tRel) then - pure (Just (QualifiedName [tableAlias, colName])) + pure (Just (ColumnName [tableAlias, colName])) else pure Nothing - +-} +baseDFExpr :: DataFrameExpr +baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () []), + orderExprs = [], + offset = Nothing, + limit = Nothing } + convertSelect :: TypeForRelExprF -> Select -> Either SQLError DataFrameExpr convertSelect typeF sel = do - let baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () []), - orderExprs = [], - offset = Nothing, - limit = Nothing } -- extract all mentioned tables into the table alias map for (dfExpr, tAliasMap, colRemap) <- case tableExpr sel of Nothing -> pure (baseDFExpr, mempty, mempty) @@ -153,64 +213,87 @@ convertSelect typeF sel = do -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes pure (dfExpr { convertExpr = explicitWithF (withF (projF (convertExpr dfExpr))) }) +-- | Slightly different processing for subselects. +convertSubSelect :: TypeForRelExprF -> TableContext -> Select -> Either SQLError (RelationalExpr, TableContext) +convertSubSelect typeF tctx sel = do + (dfExpr, subTContext, colRemap) <- case tableExpr sel of + Nothing -> pure (baseDFExpr, mempty, mempty) + Just tExpr -> convertTableExpr typeF tExpr + when (usesDataFrameFeatures dfExpr) $ Left (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") + tableContext' <- insertTables tctx subTContext + explicitWithF <- case withClause sel of + Nothing -> pure id + Just wClause -> do + wExprs <- convertWithClause typeF wClause + pure (With wExprs) + -- convert projection using table alias map to resolve column names + projF <- convertProjection typeF subTContext (projectionClause sel) -- the projection can only project on attributes from the subselect table expression + -- add with clauses + withAssocs <- tableAliasesAsWithNameAssocs subTContext + let withF = case withAssocs of + [] -> id + _ -> With withAssocs + -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes + pure (explicitWithF (withF (projF (convertExpr dfExpr))), tableContext') + + + + convertSelectItem :: TypeForRelExprF -> TableContext -> SelectItemsConvertTask -> (Int,SelectItem) -> Either SQLError SelectItemsConvertTask -convertSelectItem typeF tAliasMap acc (c,selItem) = +convertSelectItem typeF tableContext acc (c,selItem) = case selItem of -- select * from x - (Identifier (QualifiedProjectionName [Asterisk]), Nothing) -> + (Identifier (ColumnProjectionName [Asterisk]), Nothing) -> pure acc -- select sup.* from s as sup - (Identifier qpn@(QualifiedProjectionName [ProjectionName _, Asterisk]), Nothing) -> + (Identifier qpn@(ColumnProjectionName [ProjectionName _, Asterisk]), Nothing) -> pure $ acc { taskProjections = S.insert qpn (taskProjections acc) } -- select a from x - (Identifier qpn@(QualifiedProjectionName [ProjectionName col]), Nothing) -> do + (Identifier qpn@(ColumnProjectionName [ProjectionName col]), Nothing) -> do --look up unaliased column name _ <- colinfo qpn pure $ acc { taskProjections = S.insert qpn (taskProjections acc) } -- select city as x from s - (Identifier qpn@(QualifiedProjectionName [ProjectionName _]), Just newName@(AliasName newNameTxt)) -> do - pure $ acc { taskProjections = S.insert (QualifiedProjectionName [ProjectionName newNameTxt]) (taskProjections acc), + (Identifier qpn@(ColumnProjectionName [ProjectionName _]), Just newName@(ColumnAlias newNameTxt)) -> do + pure $ acc { taskProjections = S.insert (ColumnProjectionName [ProjectionName newNameTxt]) (taskProjections acc), taskRenames = taskRenames acc <> [(qpn, newName)] } -- select s.city from s - (Identifier qpn@(QualifiedProjectionName [ProjectionName tname, ProjectionName colname]), Nothing) -> do + (Identifier qpn@(ColumnProjectionName [ProjectionName tname, ProjectionName colname]), Nothing) -> do --lookup column renaming, if applicable pure $ acc { taskProjections = S.insert qpn (taskProjections acc), - taskRenames = taskRenames acc <> [(QualifiedProjectionName [ProjectionName colname], AliasName (T.intercalate "." [tname,colname]))] } + taskRenames = taskRenames acc <> [(ColumnProjectionName [ProjectionName colname], ColumnAlias (T.intercalate "." [tname,colname]))] } -- other exprs (scalarExpr, mAlias) -> do - let attrName' (Just (AliasName nam)) _ = nam + let attrName' (Just (ColumnAlias nam)) _ = nam attrName' Nothing c = "attr_" <> T.pack (show c) - atomExpr <- convertProjectionScalarExpr typeF scalarExpr + atomExpr <- convertProjectionScalarExpr typeF tableContext scalarExpr let newAttrName = attrName' mAlias c -- we need to apply the projections after the extension! pure $ acc { taskExtenders = AttributeExtendTupleExpr newAttrName atomExpr : taskExtenders acc, - taskProjections = S.insert (QualifiedProjectionName [ProjectionName newAttrName]) (taskProjections acc) + taskProjections = S.insert (ColumnProjectionName [ProjectionName newAttrName]) (taskProjections acc) } where - colinfo (QualifiedProjectionName [ProjectionName name]) = - case tableAliasForColumnName typeF (QualifiedName [name]) tAliasMap of - Left err -> Left err - Right (QualifiedName names') -> pure $ AliasName (T.intercalate "." names') - + colinfo (ColumnProjectionName [ProjectionName name]) = + findOneColumn (ColumnName [name]) tableContext convertProjection :: TypeForRelExprF -> TableContext -> [SelectItem] -> Either SQLError (RelationalExpr -> RelationalExpr) -convertProjection typeF tAliasMap selItems = do +convertProjection typeF tContext selItems = do let emptyTask = SelectItemsConvertTask { taskProjections = S.empty, taskRenames = mempty, taskExtenders = mempty } - attrName' (Just (AliasName nam)) _ = nam + attrName' (Just (ColumnAlias nam)) _ = nam attrName' Nothing c = "attr_" <> T.pack (show c) - task <- foldM (convertSelectItem typeF tAliasMap) emptyTask (zip [1::Int ..] selItems) + task <- foldM (convertSelectItem typeF tContext) emptyTask (zip [1::Int ..] selItems) --apply projections fProjection <- if S.null (taskProjections task) then pure id else do - let projFolder (attrNames, b) (QualifiedProjectionName [ProjectionName nam]) = + let projFolder (attrNames, b) (ColumnProjectionName [ProjectionName nam]) = pure (S.insert nam attrNames, b) - projFolder (attrNames, b) (QualifiedProjectionName [ProjectionName nameA, ProjectionName nameB]) = + projFolder (attrNames, b) (ColumnProjectionName [ProjectionName nameA, ProjectionName nameB]) = pure $ (S.insert (T.concat [nameA, ".", nameB]) attrNames, b) - projFolder (attrNames, relExprAttributes) (QualifiedProjectionName [ProjectionName tname, Asterisk]) = + projFolder (attrNames, relExprAttributes) (ColumnProjectionName [ProjectionName tname, Asterisk]) = pure $ (attrNames, relExprAttributes <> [tname]) (attrNames, relExprRvs) <- foldM projFolder mempty (S.toList (taskProjections task)) let attrsProj = A.some (map (\rv -> RelationalExprAttributeNames (RelationVariable rv ())) relExprRvs <> [AttributeNames attrNames]) @@ -218,33 +301,42 @@ convertProjection typeF tAliasMap selItems = do -- apply extensions let fExtended = foldr (\ext acc -> (Extend ext) . acc) id (taskExtenders task) -- apply rename - renamesSet <- foldM (\acc (qProjName, (AliasName newName)) -> do - oldName <- convertProjectionName qProjName + renamesSet <- foldM (\acc (qProjName, (ColumnAlias newName)) -> do + oldName <- convertColumnProjectionName qProjName tContext pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) let fRenames = if S.null renamesSet then id else Rename renamesSet pure (fProjection . fExtended . fRenames) -convertProjectionName :: QualifiedProjectionName -> Either SQLError AttributeName -convertProjectionName (QualifiedProjectionName names) = do +{- +convertColumnProjectionName :: ColumnProjectionName -> Either SQLError AttributeName +convertColumnProjectionName (ColumnProjectionName names) = do let namer (ProjectionName t) = pure t namer Asterisk = Left (NotSupportedError "asterisk in projection conversion") names' <- mapM namer names pure (T.concat names') +-} -convertQualifiedName :: QualifiedName -> Either SQLError AttributeName -convertQualifiedName (QualifiedName ts) = pure $ T.intercalate "." ts -convertQualifiedProjectionName :: QualifiedProjectionName -> Either SQLError AttributeName -convertQualifiedProjectionName (QualifiedProjectionName names) = do +convertUnqualifiedColumnName :: UnqualifiedColumnName -> AttributeName +convertUnqualifiedColumnName (UnqualifiedColumnName nam) = nam + +convertColumnName :: ColumnName -> TableContext -> Either SQLError AttributeName +convertColumnName colName tcontext = do + --(_, <- insertColumn Nothing colName Nothing tcontext + (TableAlias ts) <- findOneColumn colName tcontext -- wrong! why convert to a tablealias? + pure ts + +convertColumnProjectionName :: ColumnProjectionName -> TableContext -> Either SQLError AttributeName +convertColumnProjectionName qpn@(ColumnProjectionName names) tableContext = do let namer (ProjectionName t) = pure t - namer Asterisk = error "wrong asterisk" + namer Asterisk = Left $ UnexpectedAsteriskError qpn names' <- mapM namer names - pure (T.concat names') + convertColumnName (ColumnName names') tableContext convertTableExpr :: TypeForRelExprF -> TableExpr -> Either SQLError (DataFrameExpr, TableContext, ColumnRemap) convertTableExpr typeF tExpr = do - (fromExpr, tableAliasMap, columnRemap) <- convertFromClause typeF (fromClause tExpr) + (fromExpr, tContext, columnRemap) <- convertFromClause typeF (fromClause tExpr) {- let tableAliasMap' = M.filterWithKey filterRedundantAlias tableAliasMap filterRedundantAlias (QualifiedName [nam]) (RelationVariable nam' ()) | nam == nam' = False @@ -256,55 +348,55 @@ convertTableExpr typeF tExpr = do expr' <- case whereClause tExpr of Just whereExpr -> do - restrictPredExpr <- convertWhereClause typeF whereExpr + restrictPredExpr <- convertWhereClause typeF tContext whereExpr pure $ Restrict restrictPredExpr fromExpr Nothing -> pure fromExpr - orderExprs <- convertOrderByClause typeF (orderByClause tExpr) + orderExprs <- convertOrderByClause typeF tContext (orderByClause tExpr) let dfExpr = DataFrameExpr { convertExpr = expr', orderExprs = orderExprs, offset = offsetClause tExpr, limit = limitClause tExpr } - pure (dfExpr, tableAliasMap, columnRemap) + pure (dfExpr, tContext, columnRemap) -convertWhereClause :: TypeForRelExprF -> RestrictionExpr -> Either SQLError RestrictionPredicateExpr -convertWhereClause typeF (RestrictionExpr rexpr) = do +convertWhereClause :: TypeForRelExprF -> TableContext -> RestrictionExpr -> Either SQLError RestrictionPredicateExpr +convertWhereClause typeF tableContext (RestrictionExpr rexpr) = do let wrongType t = Left $ TypeMismatchError t BoolAtomType --must be boolean expression - attrName' (QualifiedName ts) = T.intercalate "." ts + attrName' (ColumnName ts) = T.intercalate "." ts case rexpr of IntegerLiteral{} -> wrongType IntegerAtomType DoubleLiteral{} -> wrongType DoubleAtomType StringLiteral{} -> wrongType TextAtomType Identifier i -> wrongType TextAtomType -- could be a better error here - BinaryOperator (Identifier a) (QualifiedName ["="]) exprMatch -> --we don't know here if this results in a boolean expression, so we pass it down - AttributeEqualityPredicate (attrName' a) <$> convertScalarExpr typeF exprMatch - BinaryOperator exprA qn exprB -> do - a <- convertScalarExpr typeF exprA - b <- convertScalarExpr typeF exprB - f <- lookupFunc qn + BinaryOperator i@(Identifier colName) (OperatorName ["="]) exprMatch -> do --we don't know here if this results in a boolean expression, so we pass it down + (tctx', colAlias) <- insertColumn Nothing colName Nothing tableContext + AttributeEqualityPredicate (unColumnAlias colAlias) <$> convertScalarExpr typeF tableContext exprMatch + BinaryOperator exprA op exprB -> do + a <- convertScalarExpr typeF tableContext exprA + b <- convertScalarExpr typeF tableContext exprB + f <- lookupOperator op pure (AtomExprPredicate (f [a,b])) InExpr inOrNotIn sexpr (InList matches') -> do - eqExpr <- convertScalarExpr typeF sexpr + eqExpr <- convertScalarExpr typeF tableContext sexpr let (match:matches) = reverse matches' - firstItem <- convertScalarExpr typeF match + firstItem <- convertScalarExpr typeF tableContext match let inFunc a b = AtomExprPredicate (FunctionAtomExpr "eq" [a,b] ()) predExpr' = inFunc eqExpr firstItem folder predExpr'' sexprItem = do - item <- convertScalarExpr typeF sexprItem + item <- convertScalarExpr typeF tableContext sexprItem pure $ OrPredicate (inFunc eqExpr item) predExpr'' res <- foldM folder predExpr' matches --be careful here once we introduce NULLs case inOrNotIn of In -> pure res NotIn -> pure (NotPredicate res) ExistsExpr subQ -> do - dfExpr <- convertSelect typeF subQ + (relExpr, tcontext') <- convertSubSelect typeF tableContext subQ --pretty sure I have to rename attributes in both the top-level query and in this one to prevent attribute conflicts- we can't rename all the attributes in the subquery, because the renamer won't know which attributes actually refer to the top-level attributes- should we just prefix all attributes unconditionally or send a signal upstream to rename attributes? - when (usesDataFrameFeatures dfExpr) $ Left (NotSupportedError "ORDER BY/LIMIT/OFFSET in EXISTS subquery") - let rexpr = Equals (Project A.empty (convertExpr dfExpr)) (RelationVariable "true" ()) + let rexpr = Equals (Project A.empty relExpr) (RelationVariable "true" ()) pure (RelationalExprPredicate rexpr) -convertScalarExpr :: TypeForRelExprF -> ScalarExpr -> Either SQLError AtomExpr -convertScalarExpr typeF expr = do +convertScalarExpr :: TypeForRelExprF -> TableContext -> ScalarExpr -> Either SQLError AtomExpr +convertScalarExpr typeF tableContext expr = do let naked = pure . NakedAtomExpr case expr of IntegerLiteral i -> naked (IntegerAtom i) @@ -313,15 +405,15 @@ convertScalarExpr typeF expr = do -- we don't have enough type context with a cast, so we default to text NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) Identifier i -> - AttributeAtomExpr <$> convertQualifiedName i - BinaryOperator exprA qn exprB -> do - a <- convertScalarExpr typeF exprA - b <- convertScalarExpr typeF exprB - f <- lookupFunc qn + AttributeAtomExpr <$> convertColumnName i tableContext + BinaryOperator exprA op exprB -> do + a <- convertScalarExpr typeF tableContext exprA + b <- convertScalarExpr typeF tableContext exprB + f <- lookupOperator op pure $ f [a,b] -convertProjectionScalarExpr :: TypeForRelExprF -> ProjectionScalarExpr -> Either SQLError AtomExpr -convertProjectionScalarExpr typeF expr = do +convertProjectionScalarExpr :: TypeForRelExprF -> TableContext -> ProjectionScalarExpr -> Either SQLError AtomExpr +convertProjectionScalarExpr typeF tableContext expr = do let naked = pure . NakedAtomExpr case expr of IntegerLiteral i -> naked (IntegerAtom i) @@ -329,19 +421,19 @@ convertProjectionScalarExpr typeF expr = do StringLiteral s -> naked (TextAtom s) NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) Identifier i -> - AttributeAtomExpr <$> convertQualifiedProjectionName i - BinaryOperator exprA qn exprB -> do - a <- convertProjectionScalarExpr typeF exprA - b <- convertProjectionScalarExpr typeF exprB - f <- lookupFunc qn + AttributeAtomExpr <$> convertColumnProjectionName i tableContext + BinaryOperator exprA op exprB -> do + a <- convertProjectionScalarExpr typeF tableContext exprA + b <- convertProjectionScalarExpr typeF tableContext exprB + f <- lookupOperator op pure $ f [a,b] -convertOrderByClause :: TypeForRelExprF -> [SortExpr] -> Either SQLError [AttributeOrderExpr] -convertOrderByClause typeF exprs = +convertOrderByClause :: TypeForRelExprF -> TableContext -> [SortExpr] -> Either SQLError [AttributeOrderExpr] +convertOrderByClause typeF tableContext exprs = mapM converter exprs where converter (SortExpr sexpr mDirection mNullsOrder) = do - atomExpr <- convertScalarExpr typeF sexpr + atomExpr <- convertScalarExpr typeF tableContext sexpr attrn <- case atomExpr of AttributeAtomExpr aname -> pure aname x -> Left (NotSupportedError (T.pack (show x))) @@ -358,24 +450,24 @@ convertOrderByClause typeF exprs = convertWithClause :: TypeForRelExprF -> WithClause -> Either SQLError WithNamesAssocs convertWithClause = undefined -type ColumnRemap = M.Map QualifiedName QualifiedName +type ColumnRemap = M.Map ColumnName ColumnName convertFromClause :: TypeForRelExprF -> [TableRef] -> Either SQLError (RelationalExpr, TableContext, ColumnRemap) convertFromClause typeF (firstRef:trefs) = do --the first table ref must be a straight RelationVariable - let convertFirstTableRef (SimpleTableRef qn@(QualifiedName [nam])) = do + let convertFirstTableRef (SimpleTableRef qn@(TableName [nam])) = do let rv = RelationVariable nam () typeR <- wrapTypeF typeF rv - let tContext = TableContext (M.singleton qn (rv, attributes typeR)) + let tContext = TableContext (M.singleton (TableAlias nam) (rv, attributes typeR, mempty)) pure (rv, tContext) -- include with clause even for simple cases because we use this mapping to columns to tables - convertFirstTableRef (AliasedTableRef tref (AliasName alias)) = do + convertFirstTableRef (AliasedTableRef tref al@(TableAlias alias)) = do (rvExpr, TableContext tContext) <- convertFirstTableRef tref (rvExpr', tContext') <- case rvExpr of RelationVariable oldName () -> - let origQn = QualifiedName [oldName] in + let origQn = TableAlias oldName in case M.lookup origQn tContext of Just res -> pure $ (RelationVariable alias (), - M.delete origQn (M.insert (QualifiedName [alias]) res tContext)) + M.delete origQn (M.insert al res tContext)) Nothing -> Left (MissingTableReferenceError origQn) other -> Left (UnexpectedRelationalExprError other) pure (rvExpr', TableContext tContext') @@ -384,20 +476,20 @@ convertFromClause typeF (firstRef:trefs) = do pure (expr', tContext'', mempty {- FIXME add column remapping-}) -- | Convert TableRefs after the first one (assumes all additional TableRefs are for joins). Returns the qualified name key that was added to the map, the underlying relexpr (not aliased so that it can used for extracting type information), and the new table context map -convertTableRef :: TypeForRelExprF -> TableContext -> TableRef -> Either SQLError (QualifiedName, RelationalExpr, TableContext) +convertTableRef :: TypeForRelExprF -> TableContext -> TableRef -> Either SQLError (TableAlias, RelationalExpr, TableContext) convertTableRef typeF tableContext tref = case tref of - SimpleTableRef qn@(QualifiedName [nam]) -> do + SimpleTableRef qn@(TableName [nam]) -> do let rv = RelationVariable nam () + ta = TableAlias nam typeRel <- wrapTypeF typeF rv - tContext' <- insertTable qn rv (attributes typeRel) tableContext - pure (qn, rv, tContext') -- include with clause even for simple cases because we use this mapping to - AliasedTableRef (SimpleTableRef qn@(QualifiedName [nam])) (AliasName newName) -> do + tContext' <- insertTable ta rv (attributes typeRel) tableContext + pure (ta, rv, tContext') -- include with clause even for simple cases because we use this mapping to + AliasedTableRef (SimpleTableRef qn@(TableName [nam])) tAlias -> do typeRel <- wrapTypeF typeF (RelationVariable nam ()) let rv = RelationVariable nam () - newKey = QualifiedName [newName] - tContext' <- insertTable newKey rv (attributes typeRel) tableContext - pure $ (newKey, RelationVariable nam (), tContext') + tContext' <- insertTable tAlias rv (attributes typeRel) tableContext + pure $ (tAlias, RelationVariable nam (), tContext') x -> Left $ NotSupportedError (T.pack (show x)) @@ -406,7 +498,6 @@ joinTableRef typeF (rvA, tcontext) (c,tref) = do -- optionally prefix attributes unelss the expr is a RelationVariable let attrRenamer x expr attrs = do renamed <- mapM (renameOneAttr x expr) attrs - traceShowM ("attrRenamer", renamed) pure (Rename (S.fromList renamed) expr) -- prefix all attributes prefixRenamer prefix expr attrs = do @@ -443,14 +534,17 @@ joinTableRef typeF (rvA, tcontext) (c,tref) = do exprA <- attrRenamer "a" rvA (S.toList attrsIntersection) pure (Join exprA rvB, tcontext') InnerJoinTableRef jtref (JoinUsing qnames) -> do - (_, rvB, tcontext') <- convertTableRef typeF tcontext jtref - let jCondAttrs = S.fromList $ map convertUnqualifiedName qnames + (tKey, rvB, tcontext') <- convertTableRef typeF tcontext jtref + let jCondAttrs = S.fromList $ map convertUnqualifiedColumnName qnames (attrsIntersection, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB --rename attributes used in the join condition - let attrsToRename = S.difference attrsIntersection jCondAttrs + let attrsToRename = S.difference attrsIntersection jCondAttrs -- traceShowM ("inner", attrsToRename, attrsIntersection, jCondAttrs) + let rvNameB = case tKey of + TableAlias ta -> ta exprA <- attrRenamer "a" rvA (S.toList attrsToRename) - pure (Join exprA rvB, tcontext') + exprB <- prefixRenamer rvNameB (RelationVariable rvNameB ()) (S.toList attrsToRename) + pure (Join exprA exprB, tcontext') InnerJoinTableRef jtref (JoinOn (JoinOnCondition joinExpr)) -> do --create a cross join but extend with the boolean sexpr @@ -469,23 +563,23 @@ joinTableRef typeF (rvA, tcontext) (c,tref) = do case rvExpr of RelationVariable nam () -> pure nam x -> Left $ NotSupportedError ("cannot derived name for relational expression " <> T.pack (show x)) - rvNameB <- case tKey of -- could be original relvar name or an alias whereas rvB is the unaliased name - QualifiedName [nam] -> pure nam - other -> Left (UnexpectedQualifiedNameError other) + + rvNameB = case tKey of + TableAlias ta -> ta rvNameA <- rvPrefix rvA -- rvPrefixB <- rvPrefix rvB exprA <- prefixRenamer rvNameA rvA (S.toList attrsA) exprB <- prefixRenamer rvNameB (RelationVariable rvNameB ()) (S.toList attrsB) -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition let joinExpr' = renameIdentifier renamer joinExpr - renamer n@(QualifiedName [tableAlias,attr]) = --lookup prefixed with table alias - case traceShow ("renamer", n) $ M.lookup n allAliases of + renamer n@(ColumnName [tAlias,attr]) = --lookup prefixed with table alias + case M.lookup (TableAlias tAlias) allAliases of -- the table was not renamed, but the attribute may have been renamed -- find the source of the attribute Nothing -> n - Just found -> error (show (tableAlias, found)) - renamer n@(QualifiedName [attr]) = error (show n) - joinRe <- convertScalarExpr typeF joinExpr' + Just found -> error (show (tAlias, found)) + renamer n@(ColumnName [attr]) = error (show n) + joinRe <- convertScalarExpr typeF tContext' joinExpr' --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name = --rename all common attrs and use the new names in the join condition let allAttrs = S.union attrsA attrsB @@ -501,14 +595,14 @@ joinTableRef typeF (rvA, tcontext) (c,tref) = do projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA))), tContext') -convertUnqualifiedName :: UnqualifiedName -> AttributeName -convertUnqualifiedName (UnqualifiedName t) = t +lookupOperator :: OperatorName -> Either SQLError ([AtomExpr] -> AtomExpr) +lookupOperator (OperatorName nam) = lookupFunc (FuncName nam) -- this could be amended to support more complex expressions such as coalesce by returning an [AtomExpr] -> AtomExpr function -lookupFunc :: QualifiedName -> Either SQLError ([AtomExpr] -> AtomExpr) +lookupFunc :: FuncName -> Either SQLError ([AtomExpr] -> AtomExpr) lookupFunc qname = case qname of - QualifiedName [nam] -> + FuncName [nam] -> case lookup nam sqlFuncs of Nothing -> Left $ NoSuchSQLFunctionError qname Just match -> pure match @@ -539,399 +633,11 @@ commonAttributeNames typeF rvA rvB = attrsB = A.attributeNameSet (attributes typeB) pure $ (S.intersection attrsA attrsB, attrsA, attrsB) - ------------------------------------------------ -{- -class SQLConvert sqlexpr where - type ConverterF sqlexpr :: Type - convert :: TypeForRelExprF -> sqlexpr -> Either SQLError (ConverterF sqlexpr) - -instance SQLConvert Select where - type ConverterF Select = DataFrameExpr - convert typeF sel = do - --new strategy- rename all attributes by default and keep a mapping of discovered attributes. At the end of conversion, if there is no overlap in base attribute names, remove the table alias prefixes. - projF <- convert typeF (projectionClause sel) - -- we have explicit with clauses written by the user, but also our own implementation-specific with expressions - explicitWithF <- case withClause sel of - Nothing -> pure id - Just wClause -> do - wExprs <- convert typeF wClause - pure (With wExprs) - - let baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () []), - orderExprs = [], - offset = Nothing, - limit = Nothing } - case tableExpr sel of - Nothing -> - Just tExpr -> do - (dfExpr, withNames) <- convert typeF tExpr - let withF = case withNames of - [] -> id - _ -> With withNames - pure (dfExpr { convertExpr = explicitWithF (withF (projF (convertExpr dfExpr))) }) - - -instance SQLConvert [SelectItem] where - type ConverterF [SelectItem] = (RelationalExpr -> RelationalExpr) - convert typeF selItems = do - --SQL projections conflate static values to appear in a table with attribute names to include in the resultant relation - --split the projections and extensions -{- let (projections, extensions) = partition isProjection selItems - isProjection (Identifier{},_) = True - isProjection _ = False-} - let emptyTask = SelectItemsConvertTask { taskProjections = S.empty, - taskRenames = mempty, - taskExtenders = mempty } - attrName' (Just (AliasName nam)) _ = nam - attrName' Nothing c = "attr_" <> T.pack (show c) - - let selItemFolder :: SelectItemsConvertTask -> (Int, SelectItem) -> Either SQLError SelectItemsConvertTask - selItemFolder acc (_, (Identifier (QualifiedProjectionName [Asterisk]), Nothing)) = pure acc - --select a from s - selItemFolder acc (_, (Identifier qpn@(QualifiedProjectionName [ProjectionName _]), Nothing)) = - pure $ acc { taskProjections = S.insert qpn (taskProjections acc) - } - --select t.a from test as t -- we don't support schemas yet- that would require matching three name components - selItemFolder acc (_, (Identifier qpn@(QualifiedProjectionName [ProjectionName tname, ProjectionName colname]), Nothing)) = - pure $ acc { taskProjections = S.insert qpn (taskProjections acc), - taskRenames = taskRenames acc <> [(QualifiedProjectionName [ProjectionName colname], AliasName (T.intercalate "." [tname,colname]))] } - -- select city as x from s - selItemFolder acc (_, (Identifier qn, Just newName@(AliasName newNameTxt))) = do - pure $ acc { taskProjections = S.insert (QualifiedProjectionName [ProjectionName newNameTxt]) (taskProjections acc), - taskRenames = taskRenames acc <> [(qn, newName)] } - -- select sup.* from s as sup - selItemFolder acc (_, (Identifier qpn@(QualifiedProjectionName [ProjectionName _, Asterisk]), Nothing)) = - pure $ acc { taskProjections = S.insert qpn (taskProjections acc) } - - selItemFolder acc (c, (scalarExpr, mAlias)) = do - atomExpr <- convert typeF scalarExpr - let newAttrName = attrName' mAlias c - -- we need to apply the projections after the extension! - pure $ acc { taskExtenders = AttributeExtendTupleExpr newAttrName atomExpr : taskExtenders acc, - taskProjections = S.insert (QualifiedProjectionName [ProjectionName newAttrName]) (taskProjections acc) - } - task <- foldM selItemFolder emptyTask (zip [1::Int ..] selItems) - --apply projections - fProjection <- if S.null (taskProjections task) then - pure id - else do - let projFolder (attrNames, b) (QualifiedProjectionName [ProjectionName nam]) = - pure (S.insert nam attrNames, b) - projFolder (attrNames, b) (QualifiedProjectionName [ProjectionName nameA, ProjectionName nameB]) = - pure $ (S.insert (T.concat [nameA, ".", nameB]) attrNames, b) - projFolder (attrNames, relExprAttributes) (QualifiedProjectionName [ProjectionName tname, Asterisk]) = - pure $ (attrNames, relExprAttributes <> [tname]) - (attrNames, relExprRvs) <- foldM projFolder mempty (S.toList (taskProjections task)) - let attrsProj = A.some (map (\rv -> RelationalExprAttributeNames (RelationVariable rv ())) relExprRvs <> [AttributeNames attrNames]) - pure $ Project attrsProj - -- apply extensions - let fExtended = foldr (\ext acc -> (Extend ext) . acc) id (taskExtenders task) - -- apply rename - renamesSet <- foldM (\acc (qProjName, (AliasName newName)) -> do - oldName <- convert typeF qProjName - pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) - let fRenames = if S.null renamesSet then id else Rename renamesSet - pure (fProjection . fExtended . fRenames) - -instance SQLConvert TableExpr where - --pass with exprs up because they must be applied after applying projections - type ConverterF TableExpr = (DataFrameExpr, WithNamesAssocs) - convert typeF tExpr = do - let renameAllAttrs = case whereClause tExpr of - Nothing -> False - Just wClause -> needsToRenameAllAttributes wClause - - (fromExpr, tableAliasMap) <- convert typeF (fromClause tExpr) - let tableAliasMap' = M.filterWithKey filterRedundantAlias tableAliasMap - filterRedundantAlias (QualifiedName [nam]) (RelationVariable nam' ()) - | nam == nam' = False - filterRedundantAlias _ _ = True - withExprs <- mapM (\(qnam, expr) -> do - nam <- convert typeF qnam - pure (WithNameExpr nam (), expr)) (M.toList tableAliasMap') - - - expr' <- case whereClause tExpr of - Just whereExpr -> do - restrictPredExpr <- convert typeF whereExpr - pure $ Restrict restrictPredExpr fromExpr - Nothing -> pure fromExpr - orderExprs <- convert typeF (orderByClause tExpr) - let dfExpr = DataFrameExpr { convertExpr = expr', - orderExprs = orderExprs, - offset = offsetClause tExpr, - limit = limitClause tExpr } - pure (dfExpr, withExprs) - --group by - --having - -instance SQLConvert [SortExpr] where - type ConverterF [SortExpr] = [AttributeOrderExpr] - convert typeF exprs = mapM converter exprs - where - converter (SortExpr sexpr mDirection mNullsOrder) = do - atomExpr <- convert typeF sexpr - attrn <- case atomExpr of - AttributeAtomExpr aname -> pure aname - x -> Left (NotSupportedError (T.pack (show x))) - let ordering = case mDirection of - Nothing -> AscendingOrder - Just Ascending -> AscendingOrder - Just Descending -> DescendingOrder - case mNullsOrder of - Nothing -> pure () - Just x -> Left (NotSupportedError (T.pack (show x))) - pure (AttributeOrderExpr attrn ordering) - -instance SQLConvert [TableRef] where - -- returns base relation expressions plus top-level renames required - type ConverterF [TableRef] = (RelationalExpr, TableAliasMap) - convert _ [] = pure (ExistingRelation relationFalse, M.empty) - convert typeF (firstRef:trefs) = do - --the first table ref must be a straight RelationVariable - (firstRel, tableAliases) <- convert typeF firstRef - (expr', tableAliases') <- foldM joinTRef (firstRel, tableAliases) (zip [1..] trefs) - pure (expr', tableAliases') - where - --TODO: if any of the previous relations have overlap in their attribute names, we must change it to prevent a natural join! - joinTRef (rvA,tAliasesA) (c,tref) = do - let attrRenamer x expr attrs = do - renamed <- mapM (renameOneAttr x expr) attrs - pure (Rename (S.fromList renamed) expr) - renameOneAttr x expr old_name = pure (old_name, new_name) - where - new_name = T.concat [prefix, ".", old_name] - prefix = case expr of - RelationVariable rvName () -> rvName - _ -> x -- probably need to return errors for some expressions - - case tref of - NaturalJoinTableRef jtref -> do - -- then natural join is the only type of join which the relational algebra supports natively - (rvB, tAliasesB) <- convert typeF jtref - pure $ (Join rvA rvB, M.union tAliasesA tAliasesB) - CrossJoinTableRef jtref -> do - --rename all columns to prefix them with a generated alias to prevent any natural join occurring, then perform normal join - -- we need the type to get all the attribute names for both relexprs - (rvB, tAliasesB) <- convert typeF jtref - case typeF rvA of - Left err -> Left (SQLRelationalError err) - Right typeA -> - case typeF rvB of - Left err -> Left (SQLRelationalError err) - Right typeB -> do - let attrsA = A.attributeNameSet (attributes typeA) - attrsB = A.attributeNameSet (attributes typeB) - attrsIntersection = S.intersection attrsA attrsB - --find intersection of attributes and rename all of them with prefix 'expr'+c+'.' - exprA <- attrRenamer "a" rvA (S.toList attrsIntersection) - pure (Join exprA rvB, M.union tAliasesA tAliasesB) - InnerJoinTableRef jtref (JoinUsing qnames) -> do - (rvB, tAliasesB) <- convert typeF jtref - jCondAttrs <- S.fromList <$> mapM (convert typeF) qnames - (attrsIntersection, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB - --rename attributes used in the join condition - let attrsToRename = S.difference attrsIntersection jCondAttrs --- traceShowM ("inner", attrsToRename, attrsIntersection, jCondAttrs) - exprA <- attrRenamer "a" rvA (S.toList attrsToRename) - pure (Join exprA rvB, M.union tAliasesA tAliasesB) - - InnerJoinTableRef jtref (JoinOn (JoinOnCondition joinExpr)) -> do - --create a cross join but extend with the boolean sexpr - --extend the table with the join conditions, then join on those - --exception: for simple attribute equality, use regular join renames using JoinOn logic - - (rvB, tAliasesB) <- convert typeF jtref - --rvA and rvB now reference potentially aliased relation variables (needs with clause to execute), but this is useful for making attributes rv-prefixed --- traceShowM ("converted", rvA, rvB, tAliases) - --extract all table aliases to create a remapping for SQL names discovered in the sexpr - let allAliases = M.union tAliasesA tAliasesB - withExpr <- With <$> tableAliasesAsWithNameAssocs allAliases - (commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF (withExpr rvA) (withExpr rvB) - -- first, execute the rename, renaming all attributes according to their table aliases - let rvPrefix rvExpr = - case rvExpr of - RelationVariable nam () -> pure nam - x -> Left $ NotSupportedError ("cannot derived name for relational expression " <> T.pack (show x)) - rvPrefixA <- rvPrefix rvA - rvPrefixB <- rvPrefix rvB - exprA <- attrRenamer rvPrefixA rvA (S.toList attrsA) - exprB <- attrRenamer rvPrefixB rvB (S.toList attrsB) - -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition - let joinExpr' = renameIdentifier renamer joinExpr - renamer n@(QualifiedName [tableAlias,attr]) = --lookup prefixed with table alias - case M.lookup n allAliases of - -- the table was not renamed, but the attribute may have been renamed - -- find the source of the attribute - Nothing -> n - Just found -> error (show (tableAlias, found)) - renamer n@(QualifiedName [attr]) = error (show n) - joinRe <- convert typeF joinExpr' - --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name = - --rename all common attrs and use the new names in the join condition - let allAttrs = S.union attrsA attrsB - firstAvailableName c allAttrs' = - let new_name = T.pack ("join_" <> show c) in - if S.member new_name allAttrs' then - firstAvailableName (c + 1) allAttrs' - else - new_name - joinName = firstAvailableName 1 allAttrs - extender = AttributeExtendTupleExpr joinName joinRe - joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) - projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) - pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA))), allAliases) - - ---type AttributeNameRemap = M.Map RelVarName AttributeName - --- | Used in join condition detection necessary for renames to enable natural joins. -commonAttributeNames :: TypeForRelExprF -> RelationalExpr -> RelationalExpr -> Either SQLError (S.Set AttributeName, S.Set AttributeName, S.Set AttributeName) -commonAttributeNames typeF rvA rvB = - case typeF rvA of - Left err -> Left (SQLRelationalError err) - Right typeA -> - case typeF rvB of - Left err -> Left (SQLRelationalError err) - Right typeB -> do - let attrsA = A.attributeNameSet (attributes typeA) - attrsB = A.attributeNameSet (attributes typeB) - pure $ (S.intersection attrsA attrsB, attrsA, attrsB) - - - --- convert a TableRef in isolation- to be used with the first TableRef only -instance SQLConvert TableRef where - -- return base relation variable expression plus a function to apply top-level rv renames using WithNameExpr - type ConverterF TableRef = (RelationalExpr, TableAliasMap) - --SELECT x FROM a,_b_ creates a cross join - convert _ (SimpleTableRef qn@(QualifiedName [nam])) = do - let rv = RelationVariable nam () - pure (rv, M.singleton qn rv) -- include with clause even for simple cases because we use this mapping to - convert typeF (AliasedTableRef tnam (AliasName newName)) = do - (rv, _) <- convert typeF tnam - pure $ (RelationVariable newName (), M.singleton (QualifiedName [newName]) rv) - convert _ x = Left $ NotSupportedError (T.pack (show x)) - - -instance SQLConvert RestrictionExpr where - type ConverterF RestrictionExpr = RestrictionPredicateExpr - convert typeF (RestrictionExpr rexpr) = do - let wrongType t = Left $ TypeMismatchError t BoolAtomType --must be boolean expression - attrName' (QualifiedName ts) = T.intercalate "." ts - case rexpr of - IntegerLiteral{} -> wrongType IntegerAtomType - DoubleLiteral{} -> wrongType DoubleAtomType - StringLiteral{} -> wrongType TextAtomType - Identifier i -> wrongType TextAtomType -- could be a better error here - BinaryOperator (Identifier a) (QualifiedName ["="]) exprMatch -> --we don't know here if this results in a boolean expression, so we pass it down - AttributeEqualityPredicate (attrName' a) <$> convert typeF exprMatch - BinaryOperator exprA qn exprB -> do - a <- convert typeF exprA - b <- convert typeF exprB - f <- lookupFunc qn - pure (AtomExprPredicate (f [a,b])) - InExpr inOrNotIn sexpr (InList matches') -> do - eqExpr <- convert typeF sexpr - let (match:matches) = reverse matches' - firstItem <- convert typeF match - let inFunc a b = AtomExprPredicate (FunctionAtomExpr "eq" [a,b] ()) - predExpr' = inFunc eqExpr firstItem - folder predExpr'' sexprItem = do - item <- convert typeF sexprItem - pure $ OrPredicate (inFunc eqExpr item) predExpr'' - res <- foldM folder predExpr' matches --be careful here once we introduce NULLs - case inOrNotIn of - In -> pure res - NotIn -> pure (NotPredicate res) - ExistsExpr subQ -> do - dfExpr <- convert typeF subQ - --pretty sure I have to rename attributes in both the top-level query and in this one to prevent attribute conflicts- we can't rename all the attributes in the subquery, because the renamer won't know which attributes actually refer to the top-level attributes- should we just prefix all attributes unconditionally or send a signal upstream to rename attributes? - when (usesDataFrameFeatures dfExpr) $ Left (NotSupportedError "ORDER BY/LIMIT/OFFSET in EXISTS subquery") - let rexpr = Equals (Project A.empty (convertExpr dfExpr)) (RelationVariable "true" ()) - pure (RelationalExprPredicate rexpr) - - --} -{- -instance SQLConvert ScalarExpr where - type ConverterF ScalarExpr = AtomExpr - convert typeF expr = do - let naked = pure . NakedAtomExpr - case expr of - IntegerLiteral i -> naked (IntegerAtom i) - DoubleLiteral d -> naked (DoubleAtom d) - StringLiteral s -> naked (TextAtom s) - -- we don't have enough type context with a cast, so we default to text - NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) - Identifier i -> - AttributeAtomExpr <$> convert typeF i - BinaryOperator exprA qn exprB -> do - a <- convert typeF exprA - b <- convert typeF exprB - f <- lookupFunc qn - pure $ f [a,b] - --- PrefixOperator qn expr -> do - - -instance SQLConvert JoinOnCondition where - type ConverterF JoinOnCondition = (RelationalExpr -> RelationalExpr) - convert typeF (JoinOnCondition expr) = do - case expr of - Identifier (QualifiedName [tAlias, colName]) -> undefined - -instance SQLConvert ProjectionScalarExpr where - type ConverterF ProjectionScalarExpr = AtomExpr - convert typeF expr = do - let naked = pure . NakedAtomExpr - case expr of - IntegerLiteral i -> naked (IntegerAtom i) - DoubleLiteral d -> naked (DoubleAtom d) - StringLiteral s -> naked (TextAtom s) - NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) - Identifier i -> - AttributeAtomExpr <$> convert typeF i - BinaryOperator exprA qn exprB -> do - a <- convert typeF exprA - b <- convert typeF exprB - f <- lookupFunc qn - pure $ f [a,b] - -instance SQLConvert QualifiedName where - type ConverterF QualifiedName = AttributeName - convert _ (QualifiedName ts) = pure $ T.intercalate "." ts - -instance SQLConvert UnqualifiedName where - type ConverterF UnqualifiedName = AttributeName - convert _ (UnqualifiedName t) = pure t - -instance SQLConvert QualifiedProjectionName where - type ConverterF QualifiedProjectionName = AttributeName - convert _ (QualifiedProjectionName names) = do - let namer (ProjectionName t) = pure t - namer Asterisk = error "wrong asterisk" - names' <- mapM namer names - pure (T.concat names') - -instance SQLConvert WithClause where - type ConverterF WithClause = WithNamesAssocs - convert typeF (WithClause True _) = Left (NotSupportedError "recursive CTEs") - convert typeF (WithClause False ctes) = do - let mapper (WithExpr (UnqualifiedName nam) subquery) = do - dfExpr <- convert typeF subquery - -- we don't support dataframe features in the cte query - when (usesDataFrameFeatures dfExpr) $ Left (NotSupportedError "ORDER BY/LIMIT/OFFSET in CTE subexpression") - pure (WithNameExpr nam (), (convertExpr dfExpr)) - -- if the subquery is a Select, how do I get a rvexpr out of it rather than a data frame- perhaps a different conversion function? - mapM mapper (NE.toList ctes) --} - -- | Used to remap SQL qualified names to new names to prevent conflicts in join conditions. -renameIdentifier :: (QualifiedName -> QualifiedName) -> ScalarExpr -> ScalarExpr +renameIdentifier :: (ColumnName -> ColumnName) -> ScalarExpr -> ScalarExpr renameIdentifier renamer sexpr = Fold.cata renamer' sexpr where - renamer' :: ScalarExprBaseF QualifiedName ScalarExpr -> ScalarExpr + renamer' :: ScalarExprBaseF ColumnName ScalarExpr -> ScalarExpr renamer' (IdentifierF n) = Identifier (renamer n) renamer' x = Fold.embed x diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index f1c752e5..fe2a8579 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, DeriveTraversable, GeneralizedNewtypeDeriving #-} module SQL.Interpreter.Select where import Text.Megaparsec import Text.Megaparsec.Char @@ -29,7 +29,10 @@ data WithClause = WithClause { isRecursive :: Bool, withExprs :: NE.NonEmpty WithExpr } deriving (Show, Eq) -data WithExpr = WithExpr UnqualifiedName Select +data WithExpr = WithExpr WithExprAlias Select + deriving (Show, Eq) + +newtype WithExprAlias = WithExprAlias Text deriving (Show, Eq) data InFlag = In | NotIn @@ -41,20 +44,20 @@ data ComparisonOperator = OpLT | OpGT | OpGTE | OpEQ | OpNE | OpLTE data QuantifiedComparisonPredicate = QCAny | QCSome | QCAll deriving (Show,Eq) -data TableRef = SimpleTableRef QualifiedName +data TableRef = SimpleTableRef TableName | InnerJoinTableRef TableRef JoinCondition | RightOuterJoinTableRef TableRef JoinCondition | LeftOuterJoinTableRef TableRef JoinCondition | FullOuterJoinTableRef TableRef JoinCondition | CrossJoinTableRef TableRef | NaturalJoinTableRef TableRef - | AliasedTableRef TableRef AliasName + | AliasedTableRef TableRef TableAlias | QueryTableRef Select deriving (Show, Eq) -- distinguish between projection attributes which may include an asterisk and scalar expressions (such as in a where clause) where an asterisk is invalid -type ProjectionScalarExpr = ScalarExprBase QualifiedProjectionName -type ScalarExpr = ScalarExprBase QualifiedName +type ProjectionScalarExpr = ScalarExprBase ColumnProjectionName +type ScalarExpr = ScalarExprBase ColumnName data ScalarExprBase n = IntegerLiteral Integer @@ -63,11 +66,11 @@ data ScalarExprBase n = | NullLiteral -- | Interval | Identifier n - | BinaryOperator (ScalarExprBase n) QualifiedName (ScalarExprBase n) - | PrefixOperator QualifiedName (ScalarExprBase n) - | PostfixOperator (ScalarExprBase n) QualifiedName + | BinaryOperator (ScalarExprBase n) OperatorName (ScalarExprBase n) + | PrefixOperator OperatorName (ScalarExprBase n) + | PostfixOperator (ScalarExprBase n) ColumnName | BetweenOperator (ScalarExprBase n) (ScalarExprBase n) (ScalarExprBase n) - | FunctionApplication QualifiedName (ScalarExprBase n) + | FunctionApplication FuncName (ScalarExprBase n) | CaseExpr { caseWhens :: [([ScalarExprBase n],ScalarExprBase n)], caseElse :: Maybe (ScalarExprBase n) } | QuantifiedComparison { qcExpr :: ScalarExprBase n, @@ -107,30 +110,39 @@ data NullsOrder = NullsFirst | NullsLast data JoinType = InnerJoin | RightOuterJoin | LeftOuterJoin | FullOuterJoin | CrossJoin | NaturalJoin deriving (Show, Eq) -data JoinCondition = JoinOn JoinOnCondition | JoinUsing [UnqualifiedName] +data JoinCondition = JoinOn JoinOnCondition | JoinUsing [UnqualifiedColumnName] deriving (Show, Eq) newtype JoinOnCondition = JoinOnCondition ScalarExpr deriving (Show, Eq) -data Alias = Alias QualifiedName (Maybe AliasName) - deriving (Show, Eq) - -data QualifiedProjectionName = QualifiedProjectionName [ProjectionName] --dot-delimited reference +data ColumnProjectionName = ColumnProjectionName [ProjectionName] --dot-delimited reference deriving (Show, Eq, Ord) data ProjectionName = ProjectionName Text | Asterisk deriving (Show, Eq, Ord) -data QualifiedName = QualifiedName [Text] +data ColumnName = ColumnName [Text] deriving (Show, Eq, Ord) -data UnqualifiedName = UnqualifiedName Text - deriving (Show, Eq) +data UnqualifiedColumnName = UnqualifiedColumnName Text + deriving (Show, Eq, Ord) + +data TableName = TableName [Text] + deriving (Show, Eq, Ord) + +data OperatorName = OperatorName [Text] + deriving (Show, Eq, Ord) + +newtype ColumnAlias = ColumnAlias { unColumnAlias :: Text } + deriving (Show, Eq, Ord) -newtype AliasName = AliasName Text +newtype TableAlias = TableAlias Text + deriving (Show, Eq, Ord, Monoid, Semigroup) + +newtype FuncName = FuncName [Text] deriving (Show, Eq) - + data Distinctness = Distinct | All deriving (Show, Eq) queryExprP :: Parser Select @@ -139,8 +151,11 @@ queryExprP = tableP <|> selectP tableP :: Parser Select tableP = do reserved "table" - tname <- qualifiedNameP + tname <- tableNameP pure $ emptySelect { tableExpr = Just $ emptyTableExpr { fromClause = [SimpleTableRef tname] } } + +tableNameP :: Parser TableName +tableNameP = TableName <$> qualifiedNameP' selectP :: Parser Select selectP = do @@ -155,13 +170,13 @@ selectP = do withClause = withClause' }) -type SelectItem = (ProjectionScalarExpr, Maybe AliasName) +type SelectItem = (ProjectionScalarExpr, Maybe ColumnAlias) selectItemListP :: Parser [SelectItem] selectItemListP = sepBy1 selectItemP comma selectItemP :: Parser SelectItem -selectItemP = (,) <$> scalarExprP <*> optional (reserved "as" *> aliasNameP) +selectItemP = (,) <$> scalarExprP <*> optional (reserved "as" *> columnAliasP) newtype RestrictionExpr = RestrictionExpr ScalarExpr deriving (Show, Eq) @@ -194,9 +209,9 @@ fromP :: Parser [TableRef] fromP = reserved "from" *> ((:) <$> nonJoinTref <*> sepByComma joinP) where nonJoinTref = choice [parens $ QueryTableRef <$> selectP, - try (AliasedTableRef <$> simpleRef <*> (reserved "as" *> aliasNameP)), + try (AliasedTableRef <$> simpleRef <*> (reserved "as" *> tableAliasP)), simpleRef] - simpleRef = SimpleTableRef <$> qualifiedNameP + simpleRef = SimpleTableRef <$> tableNameP joinP = do joinType <- joinTypeP tref <- nonJoinTref @@ -211,7 +226,7 @@ fromP = reserved "from" *> ((:) <$> nonJoinTref <*> sepByComma joinP) joinConditionP :: Parser JoinCondition joinConditionP = do (JoinOn <$> (reserved "on" *> (JoinOnCondition <$> scalarExprP))) <|> - JoinUsing <$> (reserved "using" *> parens (sepBy1 unqualifiedNameP comma)) + JoinUsing <$> (reserved "using" *> parens (sepBy1 unqualifiedColumnNameP comma)) joinTypeP :: Parser JoinType joinTypeP = choice [reserveds "cross join" $> CrossJoin, @@ -248,8 +263,17 @@ orderByP = nameP :: Parser Text nameP = quotedIdentifier <|> identifier -aliasNameP :: Parser AliasName -aliasNameP = AliasName <$> (quotedIdentifier <|> identifier) +qualifiedNameP' :: Parser [Text] +qualifiedNameP' = sepBy1 nameP (symbol ".") + +columnAliasP :: Parser ColumnAlias +columnAliasP = ColumnAlias <$> (quotedIdentifier <|> identifier) + +tableAliasP :: Parser TableAlias +tableAliasP = TableAlias <$> (quotedIdentifier <|> identifier) + +unqualifiedColumnNameP :: Parser UnqualifiedColumnName +unqualifiedColumnNameP = UnqualifiedColumnName <$> nameP scalarExprP :: QualifiedNameP a => Parser (ScalarExprBase a) scalarExprP = E.makeExprParser scalarTermP scalarExprOp @@ -289,9 +313,9 @@ scalarExprOp = binarySymbolN s = E.InfixN $ binary s qComparisonOp = E.Postfix $ try quantifiedComparisonSuffixP -qualifiedOperatorP :: Text -> Parser QualifiedName +qualifiedOperatorP :: Text -> Parser OperatorName qualifiedOperatorP sym = - QualifiedName <$> segmentsP (splitOn "." sym) <* spaceConsumer + OperatorName <$> segmentsP (splitOn "." sym) <* spaceConsumer where segmentsP :: [Text] -> Parser [Text] segmentsP segments = case segments of @@ -404,16 +428,15 @@ class QualifiedNameP a where qualifiedNameP :: Parser a -- | col, table.col, table.*, * -instance QualifiedNameP QualifiedProjectionName where +instance QualifiedNameP ColumnProjectionName where qualifiedNameP = - QualifiedProjectionName <$> sepBy1 ((ProjectionName <$> nameP) <|> (char '*' $> Asterisk)) (char '.') <* spaceConsumer + ColumnProjectionName <$> sepBy1 ((ProjectionName <$> nameP) <|> (char '*' $> Asterisk)) (char '.') <* spaceConsumer -instance QualifiedNameP QualifiedName where - qualifiedNameP = QualifiedName <$> sepBy1 nameP (char '.') +instance QualifiedNameP ColumnName where + qualifiedNameP = ColumnName <$> sepBy1 nameP (char '.') --- | For use where qualified names need not apply (such as in USING (...) clause) -unqualifiedNameP :: Parser UnqualifiedName -unqualifiedNameP = UnqualifiedName <$> nameP +withExprAliasP :: Parser WithExprAlias +withExprAliasP = WithExprAlias <$> nameP limitP :: Parser (Maybe Integer) limitP = optional (reserved "limit" *> integer) @@ -426,7 +449,7 @@ withP = do reserved "with" recursive <- try (reserved "recursive" *> pure True) <|> pure False wExprs <- sepByComma1 $ do - wName <- unqualifiedNameP + wName <- withExprAliasP reserved "as" wSelect <- parens selectP pure (WithExpr wName wSelect) diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 1efd5318..07faf78c 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -6,31 +6,50 @@ import TutorialD.Interpreter.RODatabaseContextOperator import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph import ProjectM36.DateExamples +import ProjectM36.DatabaseContext import ProjectM36.NormalizeExpr +import ProjectM36.Client import ProjectM36.Base import System.Exit import Test.HUnit import Text.Megaparsec import qualified Data.Text as T +import qualified Data.Map as M main :: IO () main = do tcounts <- runTestTT (TestList tests) if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess where - tests = [testSelect] + tests = [testFindColumn, testSelect] + + +testFindColumn :: Test +testFindColumn = TestCase $ do + let tctx = TableContext $ M.fromList [(TableAlias "s", + (RelationVariable "s" (), + attributesFromList [Attribute "city" TextAtomType, Attribute "status" IntegerAtomType], + mempty + ) + )] + assertEqual "findColumn city" [TableAlias "s"] (findColumn (ColumnName ["city"]) tctx) + assertEqual "findColumn s.city" [TableAlias "s"] (findColumn (ColumnName ["s", "city"]) tctx) testSelect :: Test testSelect = TestCase $ do -- check that SQL and tutd compile to same thing - (tgraph,transId) <- freshTransactionGraph dateExamples - let readTests = [{- + (tgraph,transId) <- freshTransactionGraph dateExamples + (sess, conn) <- dateExamplesConnection emptyNotificationCallback + + let readTests = [ -- simple relvar ("SELECT * FROM s", "(s)"), -- simple projection ("SELECT city FROM s", "(s{city})"), -- restriction ("SELECT city FROM s where status=20","((s where status=20){city})"), + -- restriction with asterisk and qualified name + ("SELECT * FROM s WHERE \"s\".\"status\"=20","(s where status=20)"), -- restriction ("SELECT status,city FROM s where status>20","((s where gt(@status,20)){status,city})"), -- extension mixed with projection @@ -50,12 +69,12 @@ testSelect = TestCase $ do ("SELECT * FROM s CROSS JOIN sp", "((s rename {s# as `s.s#`}) join sp)"), -- unaliased join using ("SELECT * FROM sp INNER JOIN sp AS sp2 USING (\"s#\")", - "((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join sp)"), + "(with (sp2 as sp) ((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join (sp2 rename {p# as `sp2.p#`, qty as `sp2.qty`})))"), -- unaliased join - ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1})"),-} + ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1})"), -- aliased join on ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#", - "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})"){-, + "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})"), -- formula extension ("SELECT status+10 FROM s", "((s : {attr_1:=add(@status,10)}) { attr_1 })"), -- extension and formula @@ -95,7 +114,7 @@ testSelect = TestCase $ do -- SELECT with no table expression ("SELECT 1,2,3","((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})"), -- basic NULL - ("SELECT NULL", "((relation{}{}:{attr_1:=Nothing}){attr_1})")-} + ("SELECT NULL", "((relation{}{}:{attr_1:=Nothing}){attr_1})") ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, @@ -113,20 +132,43 @@ testSelect = TestCase $ do --print x pure x --parse tutd - relExpr <- case parse (dataFrameP <* eof) "test" tutd of + tutdAsDFExpr <- case parse (dataFrameP <* eof) "test" tutd of Left err -> error (errorBundlePretty err) Right x -> do --print x pure x - selectAsRelExpr <- case convertSelect typeF select of + selectAsDFExpr <- case convertSelect typeF select of Left err -> error (show err) Right x -> do print x pure x --print ("selectAsRelExpr"::String, selectAsRelExpr) - assertEqual (T.unpack sql) relExpr selectAsRelExpr + assertEqual (T.unpack sql) tutdAsDFExpr selectAsDFExpr + --check that the expression can actually be executed + eEvald <- executeDataFrameExpr sess conn tutdAsDFExpr + case eEvald of + Left err -> assertFailure (show err <> ": " <> show tutdAsDFExpr) + Right _ -> pure () mapM_ check readTests -- assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") +dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection) +dateExamplesConnection callback = do + dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback []) + case dbconn of + Left err -> error (show err) + Right conn -> do + eSessionId <- createSessionAtHead conn "master" + case eSessionId of + Left err -> error (show err) + Right sessionId -> do + executeDatabaseContextExpr sessionId conn (databaseContextAsDatabaseContextExpr dateExamples) >>= eitherFail + --skipping atom functions for now- there are no atom function manipulation operators yet + commit sessionId conn >>= eitherFail + pure (sessionId, conn) + +eitherFail :: Either RelationalError a -> IO () +eitherFail (Left err) = assertFailure (show err) +eitherFail (Right _) = pure () From 6916259b2c9659cb227408dbdd1b8fc9cf79ec56 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 2 Dec 2023 02:01:36 -0500 Subject: [PATCH 018/170] add some debugging utilities for SQL conversion --- src/bin/SQL/Interpreter/Convert.hs | 538 ++++++++++++++++++----------- src/bin/SQL/Interpreter/Select.hs | 5 +- test/SQL/InterpreterTest.hs | 18 +- 3 files changed, 356 insertions(+), 205 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 573c7c13..66ac8486 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -9,18 +9,22 @@ import ProjectM36.Attribute as A import qualified ProjectM36.WithNameExpr as W import SQL.Interpreter.Select import Data.Kind (Type) -import Data.Text as T (pack,intercalate,Text,concat) +import qualified Data.Text as T import ProjectM36.Relation import Control.Monad (foldM) import qualified Data.Set as S import qualified Data.Map as M -import Data.List (foldl') +import Data.List (foldl', intercalate) import qualified Data.Functor.Foldable as Fold import qualified Data.List.NonEmpty as NE import Control.Monad (when) import ProjectM36.DataTypes.Maybe import Control.Monad (void) import Data.Maybe (fromMaybe) +import Control.Monad.Trans.State (StateT, get, put, runStateT, evalStateT) +import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Trans.Class (lift) import Debug.Trace @@ -32,6 +36,7 @@ data SQLError = NotSupportedError T.Text | UnexpectedTableNameError TableName | UnexpectedColumnNameError ColumnName | ColumnResolutionError ColumnName | + ColumnAliasResolutionError ColumnAlias | UnexpectedRelationalExprError RelationalExpr | UnexpectedAsteriskError ColumnProjectionName | AmbiguousColumnResolutionError ColumnName | @@ -41,7 +46,13 @@ data SQLError = NotSupportedError T.Text | type TypeForRelExprF = RelationalExpr -> Either RelationalError Relation ---type ConvertM = State +type ConvertM = StateT TableContext (ExceptT SQLError Identity) + +runConvertM :: TableContext -> ConvertM a -> Either SQLError (a, TableContext) +runConvertM tcontext m = runIdentity (runExceptT (runStateT m tcontext)) + +evalConvertM :: TableContext -> ConvertM a -> Either SQLError a +evalConvertM tcontext m = runIdentity (runExceptT (evalStateT m tcontext)) data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set ColumnProjectionName, taskRenames :: [(ColumnProjectionName, ColumnAlias)], @@ -52,83 +63,156 @@ data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set newtype TableContext = TableContext (M.Map TableAlias (RelationalExpr, Attributes, ColumnAliasMap)) deriving (Semigroup, Monoid, Show, Eq) +-- debugging utility function +prettyTableContext :: TableContext -> String +prettyTableContext (TableContext tMap) = "TableContext {\n" <> concatMap prettyKV (M.toList tMap) <> "}" + where + prettyKV (TableAlias k,(rvexpr, attrs, colAliasMap)) = + T.unpack k <> "::\n" <> + --prettyRv <> + --prettyAttrs <> + prettyColAliasMap colAliasMap <> "\n" + prettyColAliasMap cAMap = intercalate ", " $ map (\(ColumnAlias al, attrName') -> T.unpack al <> ":" <> T.unpack attrName') (M.toList cAMap) + +traceStateM :: ConvertM () +traceStateM = do + s <- get + traceM (prettyTableContext s) + -- key: alias value: real column attribute name type ColumnAliasMap = M.Map ColumnAlias AttributeName -tableAliasesAsWithNameAssocs :: TableContext -> Either SQLError WithNamesAssocs -tableAliasesAsWithNameAssocs (TableContext tmap) = +tableAliasesAsWithNameAssocs :: ConvertM WithNamesAssocs +tableAliasesAsWithNameAssocs = do + (TableContext tmap) <- get filter notSelfRef <$> mapM mapper (M.toList tmap) where notSelfRef (WithNameExpr nam (), RelationVariable nam' ()) | nam == nam' = False | otherwise = True notSelfRef _ = True --- mapper :: (QualifiedName, (RelationalExpr, Attributes, _)) -> Either SQLError (WithNameExpr, RelationalExpr) + mapper :: (TableAlias, (RelationalExpr, Attributes, ColumnAliasMap)) -> ConvertM (WithNameExpr, RelationalExpr) mapper (TableAlias nam, (rvExpr, _, _)) = pure (WithNameExpr nam (), rvExpr) - mapper (qn, _) = Left (NotSupportedError ("schema qualified table names: " <> T.pack (show qn))) + mapper (qn, _) = throwSQLE (NotSupportedError ("schema qualified table names: " <> T.pack (show qn))) + +throwSQLE :: SQLError -> ConvertM a +throwSQLE = lift . throwE + +-- | Pass state down to subselect, but discard any state changes from the subselect processing. +withSubSelect :: ConvertM a -> ConvertM (a, TableContext) +withSubSelect m = do + state@(TableContext orig) <- get + ret <- m + state'@(TableContext postSub) <- get + put state + -- diff the state to get just the items that were added + traceShowM ("diff orig", M.keys orig) + traceShowM ("diff postSub", M.keys postSub) + traceShowM ("diff1", M.difference postSub orig) + let diff = M.differenceWith tctxDiff postSub orig + tctxDiff (rexprA, attrsA, colAliasMapA) (_, _, colAliasMapB) = + Just (rexprA, attrsA, M.difference colAliasMapB colAliasMapA) + pure (ret, TableContext diff) -- | Insert another table into the TableContext. -insertTable :: TableAlias -> RelationalExpr -> Attributes -> TableContext -> Either SQLError TableContext -insertTable tAlias expr rtype (TableContext map') = +insertTable :: TableAlias -> RelationalExpr -> Attributes -> ConvertM () +insertTable tAlias expr rtype = do + (TableContext map') <- get case M.lookup tAlias map' of - Nothing -> pure $ TableContext $ M.insert tAlias (expr, rtype, mempty) map' - Just _ -> Left (DuplicateTableReferenceError tAlias) + Nothing -> put $ TableContext $ M.insert tAlias (expr, rtype, mempty) map' + Just _ -> throwSQLE (DuplicateTableReferenceError tAlias) -- | When a column is mentioned, it may need to be aliased. The table name must already be in the table context so that we can identify that the attribute exists. Without a table name, we must look for a uniquely named column amongst all tables. -insertColumn :: Maybe TableAlias -> ColumnName -> Maybe ColumnAlias -> TableContext -> Either SQLError (TableContext, ColumnAlias) -insertColumn mTblAlias colName mColAlias tcontext@(TableContext tmap) = do +insertColumn :: Maybe TableAlias -> ColumnName -> Maybe ColumnAlias -> ConvertM ColumnAlias +insertColumn mTblAlias colName mColAlias = do + tcontext@(TableContext tmap) <- get -- find the relevant table for the key to the right table + traceShowM ("insertColumn", colName) tblAlias' <- case mTblAlias of Just tblAlias -> do - void $ lookupTable tblAlias tcontext + void $ lookupTable tblAlias pure tblAlias - Nothing -> + Nothing ->do -- scan column names for match- if there are multiple matches, return a column ambiguity error - findOneColumn colName tcontext + traceShowM ("insertColumn", colName) + ret <- findOneColumn colName +-- traceShowM ("insertColumn2", colName) + pure ret -- insert into the column alias map let newAlias = case mColAlias of Nothing -> case colName of ColumnName [c] -> ColumnAlias c - ColumnName [_,c] -> ColumnAlias c + ColumnName [t,c] -> ColumnAlias (t <> "." <> c) Just al -> al origColName = case colName of ColumnName [c] -> c ColumnName [_,c] -> c - - when (newAlias `elem` allColumnAliases tcontext) $ Left (DuplicateColumnAliasError newAlias) + +{- when (newAlias `elem` allColumnAliases tcontext) $ do + traceShowM ("gonk error", + "colName", colName, + "mTblAlias", mTblAlias, + "mColAlias", mColAlias, + tmap) + throwSQLE (DuplicateColumnAliasError newAlias)-} --duplicate column aliases are OK --verify that the alias is not duplicated - let tcontext' = M.adjust insertCol tblAlias' tmap + let tmap' = M.adjust insertCol tblAlias' tmap insertCol (rvexpr, attrs, colMap) = (rvexpr, attrs, M.insert newAlias origColName colMap) - pure (TableContext tcontext', newAlias) - + put (TableContext tmap') + pure newAlias + +-- | Add a column alias for a column which has already been inserted into the TableContext. +addColumnAlias' :: TableContext -> TableAlias -> ColumnAlias -> AttributeName -> Either SQLError TableContext +addColumnAlias' (TableContext tctx) tAlias colAlias@(ColumnAlias colText) attr = do + case M.lookup tAlias tctx of + Nothing -> Left (ColumnAliasResolutionError colAlias) + Just (rvexpr, attrs, colMap) -> + --check that the attribute is present in attributes, then plop it into the colMap and return the updated TableContext + if attr `A.isAttributeNameContained` attrs then do + let newColMap = M.insert colAlias attr colMap + newTContext = M.insert tAlias (rvexpr, attrs, newColMap) tctx + pure (TableContext newTContext) + else do + traceShow "addColAlias'" $ Left (ColumnResolutionError (ColumnName [attr])) + +addColumnAlias :: TableAlias -> ColumnAlias -> AttributeName -> ConvertM () +addColumnAlias tAlias colAlias attrName = do + tctx <- get + case addColumnAlias' tctx tAlias colAlias attrName of + Left err -> throwSQLE err + Right tctx' -> put tctx' allColumnAliases :: TableContext -> [ColumnAlias] -allColumnAliases (TableContext tmap) = foldl' folder [] tmap +allColumnAliases (TableContext tmap) = + foldl' folder [] tmap where folder acc (_,_,colmap) = M.keys colmap <> acc -lookupTable :: TableAlias -> TableContext -> Either SQLError (RelationalExpr, Attributes, ColumnAliasMap) -lookupTable ta (TableContext map') = +lookupTable :: TableAlias -> ConvertM (RelationalExpr, Attributes, ColumnAliasMap) +lookupTable ta = do + (TableContext map') <- get case M.lookup ta map' of - Nothing -> Left (MissingTableReferenceError ta) + Nothing -> throwSQLE (MissingTableReferenceError ta) Just res -> pure res -- | Merge table contexts (used in subselects) -insertTables :: TableContext -> TableContext -> Either SQLError TableContext -insertTables (TableContext tMapA) ctxB = - foldM folder ctxB (M.toList tMapA) - where - folder acc (qn, (re,attrs, _)) = insertTable qn re attrs acc -{- -replaceTableName :: QualifiedName -> QualifiedName -> TableContext -> Either SQLError TableContext -replaceTableName oldName newName (TableContext tctx) = - case M.lookup oldName tctx of - Nothing -> Left (MissingTableReferenceError oldName) - Just match -> pure $ TableContext $ M.insert newName match (M.delete oldName tctx) --} +mergeContext :: TableContext -> ConvertM () +mergeContext (TableContext ctxB) = do + (TableContext tMapA) <- get + foldM folder () (M.toList tMapA) + where + folder acc (tAlias, (re,attrs, _)) = insertTable tAlias re attrs + -- | Find a column name or column alias in the underlying table context. Returns key into table context. -findColumn :: ColumnName -> TableContext -> [TableAlias] -findColumn targetCol (TableContext tMap) = +findColumn :: ColumnName -> ConvertM [TableAlias] +findColumn targetCol = do + tcontext <- get + pure (findColumn' targetCol tcontext) + +-- | non ConvertM version of findColumn +findColumn' :: ColumnName -> TableContext -> [TableAlias] +findColumn' targetCol (TableContext tMap) = do + traceShowM ("findColumn'", targetCol, tMap) M.foldrWithKey folder [] tMap where folder tAlias@(TableAlias tat) (rvExpr, rtype, _) acc = @@ -145,18 +229,65 @@ findColumn targetCol (TableContext tMap) = acc _ -> acc -findOneColumn :: ColumnName -> TableContext -> Either SQLError TableAlias -findOneColumn colName tcontext = - case findColumn colName tcontext of - [] -> Left (ColumnResolutionError colName) +--findColumnAlias' :: ColumnAlias + + +findOneColumn :: ColumnName -> ConvertM TableAlias +findOneColumn targetCol = do + tcontext <- get + case findOneColumn' targetCol tcontext of + Left err -> throwSQLE err + Right match -> pure match + +findOneColumn' :: ColumnName -> TableContext -> Either SQLError TableAlias +findOneColumn' targetCol tcontext = do + case findColumn' targetCol tcontext of + [] -> do + traceShow ("findOneColumn'", targetCol) $ Left (ColumnResolutionError targetCol) [match] -> pure match - _matches -> Left (AmbiguousColumnResolutionError colName) + _matches -> Left (AmbiguousColumnResolutionError targetCol) + +-- | Search the TableContext for a column alias remapping for the given column name. +attributeNameForColumnName' :: ColumnName -> TableContext -> Either SQLError AttributeName +attributeNameForColumnName' colName tcontext@(TableContext tmap) = do + traceShowM ("attributeNameForColumnName'", colName) +-- traceShowM ("attribtueNameForColumnName tmap", tmap) + tKey@(TableAlias tAlias) <- findOneColumn' colName tcontext + let (_, rvattrs, colAliases) = tmap M.! tKey + --strip table prefix, if necessary + colAlias@(ColumnAlias colAttr) <- case colName of + ColumnName [attr] -> pure $ ColumnAlias attr + ColumnName [tname,attr] -> pure $ ColumnAlias (tname <> "." <> attr) + ColumnName{} -> traceShow ("attrname", colName) $ Left $ ColumnResolutionError colName + case M.lookup colAlias colAliases of + Just _ -> pure (unColumnAlias colAlias) -- we found it, so it's valid + Nothing -> + -- look in rvattrs, so we don't need the table alias prefix. The lack of an entry in the column alias map indicates that the column was not renamed in the join condition. + if colAttr `A.isAttributeNameContained` rvattrs then + pure colAttr + --pure (T.concat [tAlias, ".", colAttr]) + else + case colName of + ColumnName [_, col] | col `A.isAttributeNameContained` rvattrs -> + -- the column has not been aliased, so we presume it can be use the column name directly + pure col + _ -> traceShow ("attrNameForColName") $ Left $ ColumnResolutionError colName + +attributeNameForColumnName :: ColumnName -> ConvertM AttributeName +attributeNameForColumnName colName = do + s <- get + traceShowM ("attributeNameForColumnName", colName) + traceStateM + case attributeNameForColumnName' colName s of + Left err -> throwSQLE err + Right al -> pure al + -wrapTypeF :: TypeForRelExprF -> RelationalExpr -> Either SQLError Relation +wrapTypeF :: TypeForRelExprF -> RelationalExpr -> ConvertM Relation wrapTypeF typeF relExpr = case typeF relExpr of - Left relError -> Left (SQLRelationalError relError) - Right v -> pure v + Left relError -> throwSQLE (SQLRelationalError relError) + Right v -> pure v -- | Return the table alias for the column name iff the attribute is unique. Used for attribute resolution. @@ -190,11 +321,11 @@ baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (Tupl offset = Nothing, limit = Nothing } -convertSelect :: TypeForRelExprF -> Select -> Either SQLError DataFrameExpr +convertSelect :: TypeForRelExprF -> Select -> ConvertM DataFrameExpr convertSelect typeF sel = do -- extract all mentioned tables into the table alias map for - (dfExpr, tAliasMap, colRemap) <- case tableExpr sel of - Nothing -> pure (baseDFExpr, mempty, mempty) + (dfExpr, colRemap) <- case tableExpr sel of + Nothing -> pure (baseDFExpr, mempty) Just tExpr -> convertTableExpr typeF tExpr -- traceShowM ("table aliases", tAliasMap) explicitWithF <- case withClause sel of @@ -204,43 +335,47 @@ convertSelect typeF sel = do pure (With wExprs) -- convert projection using table alias map to resolve column names - projF <- convertProjection typeF tAliasMap (projectionClause sel) + projF <- convertProjection typeF (projectionClause sel) -- add with clauses - withAssocs <- tableAliasesAsWithNameAssocs tAliasMap + withAssocs <- tableAliasesAsWithNameAssocs let withF = case withAssocs of [] -> id _ -> With withAssocs -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes + s <- get + traceStateM pure (dfExpr { convertExpr = explicitWithF (withF (projF (convertExpr dfExpr))) }) -- | Slightly different processing for subselects. -convertSubSelect :: TypeForRelExprF -> TableContext -> Select -> Either SQLError (RelationalExpr, TableContext) -convertSubSelect typeF tctx sel = do - (dfExpr, subTContext, colRemap) <- case tableExpr sel of - Nothing -> pure (baseDFExpr, mempty, mempty) - Just tExpr -> convertTableExpr typeF tExpr - when (usesDataFrameFeatures dfExpr) $ Left (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") - tableContext' <- insertTables tctx subTContext - explicitWithF <- case withClause sel of - Nothing -> pure id - Just wClause -> do - wExprs <- convertWithClause typeF wClause - pure (With wExprs) - -- convert projection using table alias map to resolve column names - projF <- convertProjection typeF subTContext (projectionClause sel) -- the projection can only project on attributes from the subselect table expression - -- add with clauses - withAssocs <- tableAliasesAsWithNameAssocs subTContext - let withF = case withAssocs of - [] -> id - _ -> With withAssocs - -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes - pure (explicitWithF (withF (projF (convertExpr dfExpr))), tableContext') - - - - -convertSelectItem :: TypeForRelExprF -> TableContext -> SelectItemsConvertTask -> (Int,SelectItem) -> Either SQLError SelectItemsConvertTask -convertSelectItem typeF tableContext acc (c,selItem) = +convertSubSelect :: TypeForRelExprF -> Select -> ConvertM RelationalExpr +convertSubSelect typeF sel = do + (ret, TableContext aliasDiff) <- withSubSelect $ do + (dfExpr, colRemap) <- case tableExpr sel of + Nothing -> pure (baseDFExpr, mempty) + Just tExpr -> convertTableExpr typeF tExpr + when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") + traceShowM ("convertSubSelect", colRemap) + explicitWithF <- case withClause sel of + Nothing -> pure id + Just wClause -> do + wExprs <- convertWithClause typeF wClause + pure (With wExprs) + -- convert projection using table alias map to resolve column names + projF <- convertProjection typeF (projectionClause sel) -- the projection can only project on attributes from the subselect table expression + -- add with clauses + withAssocs <- tableAliasesAsWithNameAssocs + let withF = case withAssocs of + [] -> id + _ -> With withAssocs + -- add disambiguation renaming +-- tableColumns = foldr ((\(tname,(_,_,colAliases)) acc -> acc <> map () (M.) [] (M.toList aliasDiff) +-- renamesSet <- foldM (\acc + pure (explicitWithF (withF (projF (convertExpr dfExpr)))) + traceShowM ("diff", aliasDiff) -- alias is not correct- the col alias map is empty for subquery + pure ret + +convertSelectItem :: TypeForRelExprF -> SelectItemsConvertTask -> (Int,SelectItem) -> ConvertM SelectItemsConvertTask +convertSelectItem typeF acc (c,selItem) = case selItem of -- select * from x (Identifier (ColumnProjectionName [Asterisk]), Nothing) -> @@ -267,24 +402,25 @@ convertSelectItem typeF tableContext acc (c,selItem) = (scalarExpr, mAlias) -> do let attrName' (Just (ColumnAlias nam)) _ = nam attrName' Nothing c = "attr_" <> T.pack (show c) - atomExpr <- convertProjectionScalarExpr typeF tableContext scalarExpr + atomExpr <- convertProjectionScalarExpr typeF scalarExpr let newAttrName = attrName' mAlias c -- we need to apply the projections after the extension! pure $ acc { taskExtenders = AttributeExtendTupleExpr newAttrName atomExpr : taskExtenders acc, taskProjections = S.insert (ColumnProjectionName [ProjectionName newAttrName]) (taskProjections acc) } where - colinfo (ColumnProjectionName [ProjectionName name]) = - findOneColumn (ColumnName [name]) tableContext + colinfo (ColumnProjectionName [ProjectionName name]) = do + findOneColumn (traceShow ("colinfo", name) (ColumnName [name])) -convertProjection :: TypeForRelExprF -> TableContext -> [SelectItem] -> Either SQLError (RelationalExpr -> RelationalExpr) -convertProjection typeF tContext selItems = do +convertProjection :: TypeForRelExprF -> [SelectItem] -> ConvertM (RelationalExpr -> RelationalExpr) +convertProjection typeF selItems = do +-- traceShowM ("convertProjection", selItems) let emptyTask = SelectItemsConvertTask { taskProjections = S.empty, taskRenames = mempty, taskExtenders = mempty } attrName' (Just (ColumnAlias nam)) _ = nam attrName' Nothing c = "attr_" <> T.pack (show c) - task <- foldM (convertSelectItem typeF tContext) emptyTask (zip [1::Int ..] selItems) + task <- foldM (convertSelectItem typeF) emptyTask (zip [1::Int ..] selItems) --apply projections fProjection <- if S.null (taskProjections task) then pure id @@ -302,7 +438,7 @@ convertProjection typeF tContext selItems = do let fExtended = foldr (\ext acc -> (Extend ext) . acc) id (taskExtenders task) -- apply rename renamesSet <- foldM (\acc (qProjName, (ColumnAlias newName)) -> do - oldName <- convertColumnProjectionName qProjName tContext + oldName <- convertColumnProjectionName qProjName pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) let fRenames = if S.null renamesSet then id else Rename renamesSet pure (fProjection . fExtended . fRenames) @@ -316,27 +452,25 @@ convertColumnProjectionName (ColumnProjectionName names) = do pure (T.concat names') -} - convertUnqualifiedColumnName :: UnqualifiedColumnName -> AttributeName convertUnqualifiedColumnName (UnqualifiedColumnName nam) = nam -convertColumnName :: ColumnName -> TableContext -> Either SQLError AttributeName -convertColumnName colName tcontext = do - --(_, <- insertColumn Nothing colName Nothing tcontext - (TableAlias ts) <- findOneColumn colName tcontext -- wrong! why convert to a tablealias? - pure ts +convertColumnName :: ColumnName -> ConvertM AttributeName +convertColumnName colName = do + traceShowM ("convertColumnName", colName) + attributeNameForColumnName colName -convertColumnProjectionName :: ColumnProjectionName -> TableContext -> Either SQLError AttributeName -convertColumnProjectionName qpn@(ColumnProjectionName names) tableContext = do +convertColumnProjectionName :: ColumnProjectionName -> ConvertM AttributeName +convertColumnProjectionName qpn@(ColumnProjectionName names) = do let namer (ProjectionName t) = pure t - namer Asterisk = Left $ UnexpectedAsteriskError qpn + namer Asterisk = throwSQLE $ UnexpectedAsteriskError qpn names' <- mapM namer names - convertColumnName (ColumnName names') tableContext + convertColumnName (ColumnName names') -convertTableExpr :: TypeForRelExprF -> TableExpr -> Either SQLError (DataFrameExpr, TableContext, ColumnRemap) +convertTableExpr :: TypeForRelExprF -> TableExpr -> ConvertM (DataFrameExpr, ColumnRemap) convertTableExpr typeF tExpr = do - (fromExpr, tContext, columnRemap) <- convertFromClause typeF (fromClause tExpr) + (fromExpr, columnRemap) <- convertFromClause typeF (fromClause tExpr) {- let tableAliasMap' = M.filterWithKey filterRedundantAlias tableAliasMap filterRedundantAlias (QualifiedName [nam]) (RelationVariable nam' ()) | nam == nam' = False @@ -348,19 +482,19 @@ convertTableExpr typeF tExpr = do expr' <- case whereClause tExpr of Just whereExpr -> do - restrictPredExpr <- convertWhereClause typeF tContext whereExpr + restrictPredExpr <- convertWhereClause typeF whereExpr pure $ Restrict restrictPredExpr fromExpr Nothing -> pure fromExpr - orderExprs <- convertOrderByClause typeF tContext (orderByClause tExpr) + orderExprs <- convertOrderByClause typeF (orderByClause tExpr) let dfExpr = DataFrameExpr { convertExpr = expr', orderExprs = orderExprs, offset = offsetClause tExpr, limit = limitClause tExpr } - pure (dfExpr, tContext, columnRemap) + pure (dfExpr, columnRemap) -convertWhereClause :: TypeForRelExprF -> TableContext -> RestrictionExpr -> Either SQLError RestrictionPredicateExpr -convertWhereClause typeF tableContext (RestrictionExpr rexpr) = do - let wrongType t = Left $ TypeMismatchError t BoolAtomType --must be boolean expression +convertWhereClause :: TypeForRelExprF -> RestrictionExpr -> ConvertM RestrictionPredicateExpr +convertWhereClause typeF (RestrictionExpr rexpr) = do + let wrongType t = throwSQLE $ TypeMismatchError t BoolAtomType --must be boolean expression attrName' (ColumnName ts) = T.intercalate "." ts case rexpr of IntegerLiteral{} -> wrongType IntegerAtomType @@ -368,35 +502,36 @@ convertWhereClause typeF tableContext (RestrictionExpr rexpr) = do StringLiteral{} -> wrongType TextAtomType Identifier i -> wrongType TextAtomType -- could be a better error here BinaryOperator i@(Identifier colName) (OperatorName ["="]) exprMatch -> do --we don't know here if this results in a boolean expression, so we pass it down - (tctx', colAlias) <- insertColumn Nothing colName Nothing tableContext - AttributeEqualityPredicate (unColumnAlias colAlias) <$> convertScalarExpr typeF tableContext exprMatch + traceShowM ("= bin", colName) + attrName <- attributeNameForColumnName colName + AttributeEqualityPredicate attrName <$> convertScalarExpr typeF exprMatch BinaryOperator exprA op exprB -> do - a <- convertScalarExpr typeF tableContext exprA - b <- convertScalarExpr typeF tableContext exprB + a <- convertScalarExpr typeF exprA + b <- convertScalarExpr typeF exprB f <- lookupOperator op pure (AtomExprPredicate (f [a,b])) InExpr inOrNotIn sexpr (InList matches') -> do - eqExpr <- convertScalarExpr typeF tableContext sexpr + eqExpr <- convertScalarExpr typeF sexpr let (match:matches) = reverse matches' - firstItem <- convertScalarExpr typeF tableContext match + firstItem <- convertScalarExpr typeF match let inFunc a b = AtomExprPredicate (FunctionAtomExpr "eq" [a,b] ()) predExpr' = inFunc eqExpr firstItem folder predExpr'' sexprItem = do - item <- convertScalarExpr typeF tableContext sexprItem + item <- convertScalarExpr typeF sexprItem pure $ OrPredicate (inFunc eqExpr item) predExpr'' res <- foldM folder predExpr' matches --be careful here once we introduce NULLs case inOrNotIn of In -> pure res NotIn -> pure (NotPredicate res) ExistsExpr subQ -> do - (relExpr, tcontext') <- convertSubSelect typeF tableContext subQ + relExpr <- convertSubSelect typeF subQ --pretty sure I have to rename attributes in both the top-level query and in this one to prevent attribute conflicts- we can't rename all the attributes in the subquery, because the renamer won't know which attributes actually refer to the top-level attributes- should we just prefix all attributes unconditionally or send a signal upstream to rename attributes? - let rexpr = Equals (Project A.empty relExpr) (RelationVariable "true" ()) + let rexpr = Project A.empty relExpr pure (RelationalExprPredicate rexpr) -convertScalarExpr :: TypeForRelExprF -> TableContext -> ScalarExpr -> Either SQLError AtomExpr -convertScalarExpr typeF tableContext expr = do +convertScalarExpr :: TypeForRelExprF -> ScalarExpr -> ConvertM AtomExpr +convertScalarExpr typeF expr = do let naked = pure . NakedAtomExpr case expr of IntegerLiteral i -> naked (IntegerAtom i) @@ -404,16 +539,17 @@ convertScalarExpr typeF tableContext expr = do StringLiteral s -> naked (TextAtom s) -- we don't have enough type context with a cast, so we default to text NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) - Identifier i -> - AttributeAtomExpr <$> convertColumnName i tableContext + Identifier i -> do + traceShowM ("convertScalarExpr", i) + AttributeAtomExpr <$> convertColumnName i BinaryOperator exprA op exprB -> do - a <- convertScalarExpr typeF tableContext exprA - b <- convertScalarExpr typeF tableContext exprB + a <- convertScalarExpr typeF exprA + b <- convertScalarExpr typeF exprB f <- lookupOperator op pure $ f [a,b] -convertProjectionScalarExpr :: TypeForRelExprF -> TableContext -> ProjectionScalarExpr -> Either SQLError AtomExpr -convertProjectionScalarExpr typeF tableContext expr = do +convertProjectionScalarExpr :: TypeForRelExprF -> ProjectionScalarExpr -> ConvertM AtomExpr +convertProjectionScalarExpr typeF expr = do let naked = pure . NakedAtomExpr case expr of IntegerLiteral i -> naked (IntegerAtom i) @@ -421,165 +557,169 @@ convertProjectionScalarExpr typeF tableContext expr = do StringLiteral s -> naked (TextAtom s) NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) Identifier i -> - AttributeAtomExpr <$> convertColumnProjectionName i tableContext + AttributeAtomExpr <$> convertColumnProjectionName i BinaryOperator exprA op exprB -> do - a <- convertProjectionScalarExpr typeF tableContext exprA - b <- convertProjectionScalarExpr typeF tableContext exprB + a <- convertProjectionScalarExpr typeF exprA + b <- convertProjectionScalarExpr typeF exprB f <- lookupOperator op pure $ f [a,b] -convertOrderByClause :: TypeForRelExprF -> TableContext -> [SortExpr] -> Either SQLError [AttributeOrderExpr] -convertOrderByClause typeF tableContext exprs = +convertOrderByClause :: TypeForRelExprF -> [SortExpr] -> ConvertM [AttributeOrderExpr] +convertOrderByClause typeF exprs = mapM converter exprs where converter (SortExpr sexpr mDirection mNullsOrder) = do - atomExpr <- convertScalarExpr typeF tableContext sexpr + atomExpr <- convertScalarExpr typeF sexpr attrn <- case atomExpr of AttributeAtomExpr aname -> pure aname - x -> Left (NotSupportedError (T.pack (show x))) + x -> throwSQLE (NotSupportedError (T.pack (show x))) let ordering = case mDirection of Nothing -> AscendingOrder Just Ascending -> AscendingOrder Just Descending -> DescendingOrder case mNullsOrder of Nothing -> pure () - Just x -> Left (NotSupportedError (T.pack (show x))) + Just x -> throwSQLE (NotSupportedError (T.pack (show x))) pure (AttributeOrderExpr attrn ordering) -convertWithClause :: TypeForRelExprF -> WithClause -> Either SQLError WithNamesAssocs +convertWithClause :: TypeForRelExprF -> WithClause -> ConvertM WithNamesAssocs convertWithClause = undefined type ColumnRemap = M.Map ColumnName ColumnName -convertFromClause :: TypeForRelExprF -> [TableRef] -> Either SQLError (RelationalExpr, TableContext, ColumnRemap) +convertFromClause :: TypeForRelExprF -> [TableRef] -> ConvertM (RelationalExpr, ColumnRemap) convertFromClause typeF (firstRef:trefs) = do --the first table ref must be a straight RelationVariable - let convertFirstTableRef (SimpleTableRef qn@(TableName [nam])) = do + let convertFirstTableRef (SimpleTableRef (TableName [nam])) = do let rv = RelationVariable nam () typeR <- wrapTypeF typeF rv - let tContext = TableContext (M.singleton (TableAlias nam) (rv, attributes typeR, mempty)) - pure (rv, tContext) -- include with clause even for simple cases because we use this mapping to columns to tables - convertFirstTableRef (AliasedTableRef tref al@(TableAlias alias)) = do - (rvExpr, TableContext tContext) <- convertFirstTableRef tref - (rvExpr', tContext') <- case rvExpr of - RelationVariable oldName () -> - let origQn = TableAlias oldName in - case M.lookup origQn tContext of - Just res -> pure $ (RelationVariable alias (), - M.delete origQn (M.insert al res tContext)) - Nothing -> Left (MissingTableReferenceError origQn) - other -> Left (UnexpectedRelationalExprError other) - pure (rvExpr', TableContext tContext') - (firstRel, tableAliases) <- convertFirstTableRef firstRef - (expr', tContext'') <- foldM (joinTableRef typeF) (firstRel, tableAliases) (zip [1..] trefs) - pure (expr', tContext'', mempty {- FIXME add column remapping-}) + insertTable (TableAlias nam) rv (attributes typeR) + pure rv + convertFirstTableRef (AliasedTableRef (SimpleTableRef (TableName [nam])) al@(TableAlias alias)) = do + let rv = RelationVariable nam () + typeR <- wrapTypeF typeF rv + insertTable al rv (attributes typeR) + pure (RelationVariable alias ()) + firstRel <- convertFirstTableRef firstRef + expr' <- foldM (joinTableRef typeF) firstRel (zip [1..] trefs) + pure (expr', mempty {- FIXME add column remapping-}) -- | Convert TableRefs after the first one (assumes all additional TableRefs are for joins). Returns the qualified name key that was added to the map, the underlying relexpr (not aliased so that it can used for extracting type information), and the new table context map -convertTableRef :: TypeForRelExprF -> TableContext -> TableRef -> Either SQLError (TableAlias, RelationalExpr, TableContext) -convertTableRef typeF tableContext tref = +convertTableRef :: TypeForRelExprF -> TableRef -> ConvertM (TableAlias, RelationalExpr) +convertTableRef typeF tref = case tref of SimpleTableRef qn@(TableName [nam]) -> do let rv = RelationVariable nam () ta = TableAlias nam typeRel <- wrapTypeF typeF rv - tContext' <- insertTable ta rv (attributes typeRel) tableContext - pure (ta, rv, tContext') -- include with clause even for simple cases because we use this mapping to + tContext' <- insertTable ta rv (attributes typeRel) + pure (ta, rv) -- include with clause even for simple cases because we use this mapping to AliasedTableRef (SimpleTableRef qn@(TableName [nam])) tAlias -> do typeRel <- wrapTypeF typeF (RelationVariable nam ()) let rv = RelationVariable nam () - tContext' <- insertTable tAlias rv (attributes typeRel) tableContext - pure $ (tAlias, RelationVariable nam (), tContext') - x -> Left $ NotSupportedError (T.pack (show x)) + tContext' <- insertTable tAlias rv (attributes typeRel) + pure $ (tAlias, RelationVariable nam ()) + x -> throwSQLE $ NotSupportedError (T.pack (show x)) -joinTableRef :: TypeForRelExprF -> (RelationalExpr, TableContext) -> (Int, TableRef) -> Either SQLError (RelationalExpr, TableContext) -joinTableRef typeF (rvA, tcontext) (c,tref) = do +joinTableRef :: TypeForRelExprF -> RelationalExpr -> (Int, TableRef) -> ConvertM RelationalExpr +joinTableRef typeF rvA (c,tref) = do -- optionally prefix attributes unelss the expr is a RelationVariable let attrRenamer x expr attrs = do renamed <- mapM (renameOneAttr x expr) attrs pure (Rename (S.fromList renamed) expr) -- prefix all attributes - prefixRenamer prefix expr attrs = do - renamed <- mapM (prefixOneAttr prefix) attrs + prefixRenamer tAlias@(TableAlias prefix) expr attrs = do + renamed <- mapM (prefixOneAttr tAlias) attrs pure (Rename (S.fromList renamed) expr) - prefixOneAttr prefix old_name = pure (old_name, new_name) - where - new_name = T.concat [prefix, ".", old_name] - renameOneAttr x expr old_name = pure (old_name, new_name) + prefixOneAttr tAlias@(TableAlias prefix) old_name = do + -- insert into columnAliasMap + let new_name = T.concat [prefix, ".", old_name] + traceShowM ("prefixOneAttr", tAlias, old_name, new_name) + addColumnAlias tAlias (ColumnAlias new_name) old_name + pure (old_name, new_name) + renameOneAttr x expr old_name = do + traceShowM ("renameOneAttr", old_name, new_name) + addColumnAlias (TableAlias prefix) (ColumnAlias new_name) old_name + pure (old_name, new_name) where new_name = T.concat [prefix, ".", old_name] prefix = case expr of RelationVariable rvName () -> rvName _ -> x -- probably need to return errors for some expressions - case tref of - NaturalJoinTableRef jtref -> do - -- then natural join is the only type of join which the relational algebra supports natively - (_, rvB, tcontext') <- convertTableRef typeF tcontext jtref - pure $ (Join rvA rvB, tcontext') - CrossJoinTableRef jtref -> do + crossJoin jtref = do --rename all columns to prefix them with a generated alias to prevent any natural join occurring, then perform normal join -- we need the type to get all the attribute names for both relexprs - (tKey, rvB, tcontext'@(TableContext tmap')) <- convertTableRef typeF tcontext jtref + (tKey, rvB) <- convertTableRef typeF jtref case typeF rvA of - Left err -> Left (SQLRelationalError err) + Left err -> throwSQLE (SQLRelationalError err) Right typeA -> case typeF rvB of - Left err -> Left (SQLRelationalError err) + Left err -> throwSQLE (SQLRelationalError err) Right typeB -> do let attrsA = A.attributeNameSet (attributes typeA) attrsB = A.attributeNameSet (attributes typeB) attrsIntersection = S.intersection attrsA attrsB --find intersection of attributes and rename all of them with prefix 'expr'+c+'.' exprA <- attrRenamer "a" rvA (S.toList attrsIntersection) - pure (Join exprA rvB, tcontext') + pure (Join exprA rvB) + case tref of + SimpleTableRef tname -> -- a simple table ref in this position implies a cross join (no join condition unless it appears in the where clause) + crossJoin (SimpleTableRef tname) + NaturalJoinTableRef jtref -> do + -- then natural join is the only type of join which the relational algebra supports natively + (_, rvB) <- convertTableRef typeF jtref + pure $ Join rvA rvB + CrossJoinTableRef jtref -> crossJoin jtref InnerJoinTableRef jtref (JoinUsing qnames) -> do - (tKey, rvB, tcontext') <- convertTableRef typeF tcontext jtref + (tKey, rvB) <- convertTableRef typeF jtref let jCondAttrs = S.fromList $ map convertUnqualifiedColumnName qnames (attrsIntersection, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB --rename attributes used in the join condition let attrsToRename = S.difference attrsIntersection jCondAttrs -- traceShowM ("inner", attrsToRename, attrsIntersection, jCondAttrs) - let rvNameB = case tKey of + rvNameB = case tKey of TableAlias ta -> ta exprA <- attrRenamer "a" rvA (S.toList attrsToRename) - exprB <- prefixRenamer rvNameB (RelationVariable rvNameB ()) (S.toList attrsToRename) - pure (Join exprA exprB, tcontext') + exprB <- prefixRenamer tKey (RelationVariable rvNameB ()) (S.toList attrsToRename) + pure (Join exprA exprB) InnerJoinTableRef jtref (JoinOn (JoinOnCondition joinExpr)) -> do --create a cross join but extend with the boolean sexpr --extend the table with the join conditions, then join on those --exception: for simple attribute equality, use regular join renames using JoinOn logic - (tKey, rvB, tContext'@(TableContext allAliases)) <- convertTableRef typeF tcontext jtref + (tKey, rvB) <- convertTableRef typeF jtref --rvA and rvB now reference potentially aliased relation variables (needs with clause to execute), but this is useful for making attributes rv-prefixed -- traceShowM ("converted", rvA, rvB, tAliases) --extract all table aliases to create a remapping for SQL names discovered in the sexpr - withExpr <- With <$> tableAliasesAsWithNameAssocs tContext' + withExpr <- With <$> tableAliasesAsWithNameAssocs (commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF (withExpr rvA) (withExpr rvB) -- first, execute the rename, renaming all attributes according to their table aliases let rvPrefix rvExpr = case rvExpr of RelationVariable nam () -> pure nam - x -> Left $ NotSupportedError ("cannot derived name for relational expression " <> T.pack (show x)) + x -> throwSQLE $ NotSupportedError ("cannot derived name for relational expression " <> T.pack (show x)) rvNameB = case tKey of TableAlias ta -> ta rvNameA <- rvPrefix rvA -- rvPrefixB <- rvPrefix rvB - exprA <- prefixRenamer rvNameA rvA (S.toList attrsA) - exprB <- prefixRenamer rvNameB (RelationVariable rvNameB ()) (S.toList attrsB) + exprA <- prefixRenamer (TableAlias rvNameA) rvA (S.toList attrsA) + exprB <- prefixRenamer tKey (RelationVariable rvNameB ()) (S.toList attrsB) + traceShowM ("exprA", exprA) + traceShowM ("exprB", exprB) -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition - let joinExpr' = renameIdentifier renamer joinExpr - renamer n@(ColumnName [tAlias,attr]) = --lookup prefixed with table alias - case M.lookup (TableAlias tAlias) allAliases of - -- the table was not renamed, but the attribute may have been renamed - -- find the source of the attribute - Nothing -> n - Just found -> error (show (tAlias, found)) - renamer n@(ColumnName [attr]) = error (show n) - joinRe <- convertScalarExpr typeF tContext' joinExpr' + tcontext <- get +{- let joinExpr' = renameIdentifier renamer joinExpr + renamer colName = + case attributeNameForColumnName' (traceShow ("inner join", colName) colName) tcontext of + Left err -> error (show err) + Right attrName -> (ColumnName [attrName]) + traceShowM ("joinExpr'", joinExpr')-} + joinRe <- convertScalarExpr typeF joinExpr --' why are we renaming here- can't we call attributenameforcolumnname in the scalarexpr conversion??? --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name = --rename all common attrs and use the new names in the join condition let allAttrs = S.union attrsA attrsB @@ -593,18 +733,18 @@ joinTableRef typeF (rvA, tcontext) (c,tref) = do extender = AttributeExtendTupleExpr joinName joinRe joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) - pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA))), tContext') + pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA)))) -lookupOperator :: OperatorName -> Either SQLError ([AtomExpr] -> AtomExpr) +lookupOperator :: OperatorName -> ConvertM ([AtomExpr] -> AtomExpr) lookupOperator (OperatorName nam) = lookupFunc (FuncName nam) -- this could be amended to support more complex expressions such as coalesce by returning an [AtomExpr] -> AtomExpr function -lookupFunc :: FuncName -> Either SQLError ([AtomExpr] -> AtomExpr) +lookupFunc :: FuncName -> ConvertM ([AtomExpr] -> AtomExpr) lookupFunc qname = case qname of FuncName [nam] -> case lookup nam sqlFuncs of - Nothing -> Left $ NoSuchSQLFunctionError qname + Nothing -> throwSQLE $ NoSuchSQLFunctionError qname Just match -> pure match where f n args = FunctionAtomExpr n args () @@ -621,13 +761,13 @@ lookupFunc qname = ] -- | Used in join condition detection necessary for renames to enable natural joins. -commonAttributeNames :: TypeForRelExprF -> RelationalExpr -> RelationalExpr -> Either SQLError (S.Set AttributeName, S.Set AttributeName, S.Set AttributeName) +commonAttributeNames :: TypeForRelExprF -> RelationalExpr -> RelationalExpr -> ConvertM (S.Set AttributeName, S.Set AttributeName, S.Set AttributeName) commonAttributeNames typeF rvA rvB = case typeF rvA of - Left err -> Left (SQLRelationalError err) + Left err -> throwSQLE (SQLRelationalError err) Right typeA -> case typeF rvB of - Left err -> Left (SQLRelationalError err) + Left err -> throwSQLE (SQLRelationalError err) Right typeB -> do let attrsA = A.attributeNameSet (attributes typeA) attrsB = A.attributeNameSet (attributes typeB) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index fe2a8579..84cc08de 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -206,8 +206,9 @@ tableExprP = TableExpr <$> fromP <*> optional whereP <*> option [] groupByP <*> optional havingP <*> option [] orderByP <*> limitP <*> offsetP fromP :: Parser [TableRef] -fromP = reserved "from" *> ((:) <$> nonJoinTref <*> sepByComma joinP) +fromP = reserved "from" *> (concat <$> sepByComma trefs) where + trefs = ((:) <$> nonJoinTref <*> many joinP) nonJoinTref = choice [parens $ QueryTableRef <$> selectP, try (AliasedTableRef <$> simpleRef <*> (reserved "as" *> tableAliasP)), simpleRef] @@ -433,7 +434,7 @@ instance QualifiedNameP ColumnProjectionName where ColumnProjectionName <$> sepBy1 ((ProjectionName <$> nameP) <|> (char '*' $> Asterisk)) (char '.') <* spaceConsumer instance QualifiedNameP ColumnName where - qualifiedNameP = ColumnName <$> sepBy1 nameP (char '.') + qualifiedNameP = ColumnName <$> sepBy1 nameP (char '.') <* spaceConsumer withExprAliasP :: Parser WithExprAlias withExprAliasP = WithExprAlias <$> nameP diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 07faf78c..5e381b25 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -32,8 +32,12 @@ testFindColumn = TestCase $ do mempty ) )] - assertEqual "findColumn city" [TableAlias "s"] (findColumn (ColumnName ["city"]) tctx) - assertEqual "findColumn s.city" [TableAlias "s"] (findColumn (ColumnName ["s", "city"]) tctx) + let findCol colName = + case runConvertM tctx (findColumn colName) of + Left err -> error (show err) + Right val -> fst val + assertEqual "findColumn city" [TableAlias "s"] (findCol (ColumnName ["city"])) + assertEqual "findColumn s.city" [TableAlias "s"] (findCol (ColumnName ["s", "city"])) testSelect :: Test testSelect = TestCase $ do @@ -50,6 +54,10 @@ testSelect = TestCase $ do ("SELECT city FROM s where status=20","((s where status=20){city})"), -- restriction with asterisk and qualified name ("SELECT * FROM s WHERE \"s\".\"status\"=20","(s where status=20)"), + -- join via where clause + ("SELECT city FROM s, sp where \"s\".\"s#\" = \"sp\".\"s#\"", + "((((s rename {s# as `s.s#`}) join sp) where `s.s#` = @s#){city})" + ), -- restriction ("SELECT status,city FROM s where status>20","((s where gt(@status,20)){status,city})"), -- extension mixed with projection @@ -91,7 +99,9 @@ testSelect = TestCase $ do ("SELECT * FROM s WHERE s# NOT IN ('S1','S2')", "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))"), -- where exists - ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s.s#\"=\"sp.s#\")","((s rename {s# as `s.s#`}) where ((sp rename {s# as `sp.s#`}) where s#))"), + -- complication: we need to add attribute renamers due to the subselect + ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s\".\"s#\"=\"sp\".\"s#\")", + "((s rename {s# as `s.s#`}) where (((sp rename {s# as `sp.s#`}) where `s.s#`= @`sp.s#`){}))"), -- where not exists -- group by -- group by having @@ -137,7 +147,7 @@ testSelect = TestCase $ do Right x -> do --print x pure x - selectAsDFExpr <- case convertSelect typeF select of + selectAsDFExpr <- case evalConvertM mempty (convertSelect typeF select) of Left err -> error (show err) Right x -> do print x From 029f74b6b47084a54d784708df16d0d4e02ff2a2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 4 Dec 2023 00:11:23 -0500 Subject: [PATCH 019/170] fix with clauses --- src/bin/SQL/Interpreter/Convert.hs | 67 +++++++++++++++++------------- test/SQL/InterpreterTest.hs | 10 ++--- 2 files changed, 43 insertions(+), 34 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 66ac8486..5b0e56ae 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -5,11 +5,12 @@ import ProjectM36.Base import ProjectM36.Error import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), AttributeOrder(..),Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A -import ProjectM36.Attribute as A +import qualified ProjectM36.Attribute as A import qualified ProjectM36.WithNameExpr as W import SQL.Interpreter.Select import Data.Kind (Type) import qualified Data.Text as T +import qualified ProjectM36.WithNameExpr as With import ProjectM36.Relation import Control.Monad (foldM) import qualified Data.Set as S @@ -218,12 +219,12 @@ findColumn' targetCol (TableContext tMap) = do folder tAlias@(TableAlias tat) (rvExpr, rtype, _) acc = case targetCol of ColumnName [colName'] -> - if S.member colName' (attributeNameSet rtype) then + if S.member colName' (A.attributeNameSet rtype) then tAlias : acc else acc ColumnName [tPrefix, colName'] -> - if tat == tPrefix && S.member colName' (attributeNameSet rtype) then + if tat == tPrefix && S.member colName' (A.attributeNameSet rtype) then tAlias : acc else acc @@ -323,19 +324,20 @@ baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (Tupl convertSelect :: TypeForRelExprF -> Select -> ConvertM DataFrameExpr convertSelect typeF sel = do - -- extract all mentioned tables into the table alias map for + wExprs <- case withClause sel of + Nothing -> pure mempty + Just wClause -> do + convertWithClause typeF wClause + -- extract all mentioned tables into the table alias map for + let typeF' = appendWithsToTypeF typeF wExprs (dfExpr, colRemap) <- case tableExpr sel of Nothing -> pure (baseDFExpr, mempty) - Just tExpr -> convertTableExpr typeF tExpr + Just tExpr -> convertTableExpr typeF' tExpr -- traceShowM ("table aliases", tAliasMap) - explicitWithF <- case withClause sel of - Nothing -> pure id - Just wClause -> do - wExprs <- convertWithClause typeF wClause - pure (With wExprs) + let explicitWithF = if null wExprs then id else With wExprs -- convert projection using table alias map to resolve column names - projF <- convertProjection typeF (projectionClause sel) + projF <- convertProjection typeF' (projectionClause sel) -- add with clauses withAssocs <- tableAliasesAsWithNameAssocs let withF = case withAssocs of @@ -344,24 +346,35 @@ convertSelect typeF sel = do -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes s <- get traceStateM - pure (dfExpr { convertExpr = explicitWithF (withF (projF (convertExpr dfExpr))) }) + pure (dfExpr { convertExpr = explicitWithF (withF (projF (convertExpr dfExpr))) }) + +-- returns a new typeF function which adds type checking for "with" clause expressions +appendWithsToTypeF :: TypeForRelExprF -> WithNamesAssocs -> TypeForRelExprF +appendWithsToTypeF typeF withAssocs relExpr = + case relExpr of + expr@(RelationVariable x ()) -> case With.lookup x withAssocs of + Nothing -> typeF expr + Just matchExpr -> typeF matchExpr + other -> typeF other + -- | Slightly different processing for subselects. convertSubSelect :: TypeForRelExprF -> Select -> ConvertM RelationalExpr convertSubSelect typeF sel = do (ret, TableContext aliasDiff) <- withSubSelect $ do + wExprs <- case withClause sel of + Nothing -> pure mempty + Just wClause -> do + convertWithClause typeF wClause + let typeF' = appendWithsToTypeF typeF wExprs (dfExpr, colRemap) <- case tableExpr sel of Nothing -> pure (baseDFExpr, mempty) - Just tExpr -> convertTableExpr typeF tExpr + Just tExpr -> convertTableExpr typeF' tExpr when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") traceShowM ("convertSubSelect", colRemap) - explicitWithF <- case withClause sel of - Nothing -> pure id - Just wClause -> do - wExprs <- convertWithClause typeF wClause - pure (With wExprs) + let explicitWithF = if null wExprs then id else With wExprs -- convert projection using table alias map to resolve column names - projF <- convertProjection typeF (projectionClause sel) -- the projection can only project on attributes from the subselect table expression + projF <- convertProjection typeF' (projectionClause sel) -- the projection can only project on attributes from the subselect table expression -- add with clauses withAssocs <- tableAliasesAsWithNameAssocs let withF = case withAssocs of @@ -471,15 +484,6 @@ convertColumnProjectionName qpn@(ColumnProjectionName names) = do convertTableExpr :: TypeForRelExprF -> TableExpr -> ConvertM (DataFrameExpr, ColumnRemap) convertTableExpr typeF tExpr = do (fromExpr, columnRemap) <- convertFromClause typeF (fromClause tExpr) -{- let tableAliasMap' = M.filterWithKey filterRedundantAlias tableAliasMap - filterRedundantAlias (QualifiedName [nam]) (RelationVariable nam' ()) - | nam == nam' = False - filterRedundantAlias _ _ = True-} -{- withExprs <- mapM (\(qnam, expr) -> do - nam <- convertQualifiedName qnam - pure (WithNameExpr nam (), expr)) (M.toList tableAliasMap')-} - - expr' <- case whereClause tExpr of Just whereExpr -> do restrictPredExpr <- convertWhereClause typeF whereExpr @@ -584,7 +588,12 @@ convertOrderByClause typeF exprs = convertWithClause :: TypeForRelExprF -> WithClause -> ConvertM WithNamesAssocs -convertWithClause = undefined +convertWithClause typeF wClause = + mapM convertOneWith (NE.toList (withExprs wClause)) + where + convertOneWith (WithExpr (WithExprAlias alias) sel) = do + relExpr <- convertSubSelect typeF sel + pure (WithNameExpr alias (), relExpr) type ColumnRemap = M.Map ColumnName ColumnName diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 5e381b25..5d18bd8b 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -98,10 +98,6 @@ testSelect = TestCase $ do -- NOT IN() ("SELECT * FROM s WHERE s# NOT IN ('S1','S2')", "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))"), - -- where exists - -- complication: we need to add attribute renamers due to the subselect - ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s\".\"s#\"=\"sp\".\"s#\")", - "((s rename {s# as `s.s#`}) where (((sp rename {s# as `sp.s#`}) where `s.s#`= @`sp.s#`){}))"), -- where not exists -- group by -- group by having @@ -124,7 +120,11 @@ testSelect = TestCase $ do -- SELECT with no table expression ("SELECT 1,2,3","((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})"), -- basic NULL - ("SELECT NULL", "((relation{}{}:{attr_1:=Nothing}){attr_1})") +-- ("SELECT NULL", "((relation{}{}:{attr_1:=Nothing}){attr_1})"), + -- where exists + -- complication: we need to add attribute renamers due to the subselect + ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s\".\"s#\"=\"sp\".\"s#\")", + "((s rename {s# as `s.s#`}) where (((sp rename {s# as `sp.s#`}) where `s.s#`= @`sp.s#`){}))") ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, From d82d9517f3cef44877b87e55cb51c8fbff49c041 Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 22 Dec 2023 10:28:08 -0500 Subject: [PATCH 020/170] WIP non-compiling refactor for tableexpr-tracking column references --- src/bin/SQL/Interpreter/Convert.hs | 207 ++++++++++++++++---------- src/lib/ProjectM36/StaticOptimizer.hs | 22 +++ test/SQL/InterpreterTest.hs | 8 +- 3 files changed, 153 insertions(+), 84 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 5b0e56ae..5937e2cf 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -12,18 +12,19 @@ import Data.Kind (Type) import qualified Data.Text as T import qualified ProjectM36.WithNameExpr as With import ProjectM36.Relation -import Control.Monad (foldM) +import Control.Monad (foldM, liftM) import qualified Data.Set as S import qualified Data.Map as M -import Data.List (foldl', intercalate) +import Data.List (foldl', intercalate, find) import qualified Data.Functor.Foldable as Fold import qualified Data.List.NonEmpty as NE import Control.Monad (when) import ProjectM36.DataTypes.Maybe +import ProjectM36.StaticOptimizer import Control.Monad (void) import Data.Maybe (fromMaybe) import Control.Monad.Trans.State (StateT, get, put, runStateT, evalStateT) -import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) +import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT, catchE) import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Trans.Class (lift) @@ -60,20 +61,29 @@ data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set taskExtenders :: [ExtendTupleExpr] } deriving (Show, Eq) ---over the course of conversion, we collect all the table aliases we encounter, including non-aliased table references, including the type of the table -newtype TableContext = TableContext (M.Map TableAlias (RelationalExpr, Attributes, ColumnAliasMap)) +--over the course of conversion of a table expression, we collect all the table aliases we encounter, including non-aliased table references, including the type of the table, projections have their own name resolution system +newtype TableContext = TableContext (M.Map TableAlias (RelationalExpr, Attributes, ColumnAliasRemapper)) deriving (Semigroup, Monoid, Show, Eq) +-- (real attribute name in table- immutable, (renamed "preferred" attribute name needed to disambiguate names on conflict, set of names which are used to reference the "preferred" name) +type AttributeAlias = AttributeName +-- the AttributeAlias is necessary when then is otherwise a naming conflict such as with join conditions which would otherwise cause duplicate column names which SQL supports but the relational algebra does not +type ColumnAliasRemapper = M.Map AttributeName (AttributeAlias, S.Set ColumnName) + +insertIntoColumnAliasRemap' :: AttributeName -> AttributeAlias -> ColumnName -> ColumnAliasRemapper + -- debugging utility function prettyTableContext :: TableContext -> String prettyTableContext (TableContext tMap) = "TableContext {\n" <> concatMap prettyKV (M.toList tMap) <> "}" where - prettyKV (TableAlias k,(rvexpr, attrs, colAliasMap)) = + prettyKV (TableAlias k,(rvexpr, attrs, aliasMap)) = T.unpack k <> "::\n" <> - --prettyRv <> - --prettyAttrs <> - prettyColAliasMap colAliasMap <> "\n" - prettyColAliasMap cAMap = intercalate ", " $ map (\(ColumnAlias al, attrName') -> T.unpack al <> ":" <> T.unpack attrName') (M.toList cAMap) + prettyColumnAliasRemapper aliasMap + +prettyColumnAliasRemapper :: ColumnAliasRemapper -> String +prettyColumnAliasRemapper cAMap = intercalate ", " $ map (\(realAttr, (attrAlias, colNameSet)) -> T.unpack realAttr <> ":" <> T.unpack attrAlias <> ":{" <> show colNameSet <> "}") (M.toList cAMap) + + traceStateM :: ConvertM () traceStateM = do @@ -91,7 +101,7 @@ tableAliasesAsWithNameAssocs = do notSelfRef (WithNameExpr nam (), RelationVariable nam' ()) | nam == nam' = False | otherwise = True notSelfRef _ = True - mapper :: (TableAlias, (RelationalExpr, Attributes, ColumnAliasMap)) -> ConvertM (WithNameExpr, RelationalExpr) +-- mapper :: (TableAlias, (RelationalExpr, Attributes)) -> ConvertM (WithNameExpr, RelationalExpr) mapper (TableAlias nam, (rvExpr, _, _)) = pure (WithNameExpr nam (), rvExpr) mapper (qn, _) = throwSQLE (NotSupportedError ("schema qualified table names: " <> T.pack (show qn))) @@ -112,22 +122,46 @@ withSubSelect m = do let diff = M.differenceWith tctxDiff postSub orig tctxDiff (rexprA, attrsA, colAliasMapA) (_, _, colAliasMapB) = Just (rexprA, attrsA, M.difference colAliasMapB colAliasMapA) + tctxDiff (rexprA, attrsA, alMap) (_, _,_) = + Just (rexprA, attrsA, alMap) pure (ret, TableContext diff) --- | Insert another table into the TableContext. -insertTable :: TableAlias -> RelationalExpr -> Attributes -> ConvertM () -insertTable tAlias expr rtype = do +-- if we find a column naming conflict, generate a non-conflicting name for insertion into the column alias map +generateColumnAlias :: TableAlias -> AttributeName -> ConvertM ColumnAlias +generateColumnAlias (TableAlias tAlias) attrName = do + tctx <- get + let potentialNames = map ColumnName ([[attrName], + [tAlias <> "." <> attrName]] <> + map (\x -> [tAlias <> "." <> attrName <> T.pack (show x)]) [1..]) + nameIsAvailable nam = + case findOneColumn' nam tctx of + Left ColumnResolutionError{} -> --no match, so we can use this name + True + _ -> False --some conflict, so loop + firstAvailableName = find nameIsAvailable potentialNames + traceShowM ("generateColumnAlias scan", tAlias, attrName, firstAvailableName) + case firstAvailableName of + Just (ColumnName [nam]) -> pure (ColumnAlias nam) + _ -> throwSQLE (ColumnResolutionError (ColumnName [attrName])) + +-- | Insert another table into the TableContext. Returns an alias map of any columns which could conflict with column names already present in the TableContext so that they can be optionally renamed. +insertTable :: TableAlias -> RelationalExpr -> Attributes -> ConvertM ColumnAliasMap +insertTable tAlias@(TableAlias tAlias') expr rtype = do (TableContext map') <- get case M.lookup tAlias map' of - Nothing -> put $ TableContext $ M.insert tAlias (expr, rtype, mempty) map' + Nothing -> do + put $ TableContext $ M.insert tAlias (expr, rtype, mempty) map' + traceShowM ("insertTable", tAlias) + traceStateM + pure mempty Just _ -> throwSQLE (DuplicateTableReferenceError tAlias) --- | When a column is mentioned, it may need to be aliased. The table name must already be in the table context so that we can identify that the attribute exists. Without a table name, we must look for a uniquely named column amongst all tables. -insertColumn :: Maybe TableAlias -> ColumnName -> Maybe ColumnAlias -> ConvertM ColumnAlias -insertColumn mTblAlias colName mColAlias = do +-- | When a column is mentioned, it may need to be aliased. The table name must already be in the table context so that we can identify that the attribute exists. Without a table name, we must look for a uniquely named column amongst all tables. Thus, we pre-emptively eliminate duplicate column names. +noteColumnMention :: Maybe TableAlias -> ColumnName -> Maybe ColumnAlias -> ConvertM ColumnAlias +noteColumnMention mTblAlias colName mColAlias = do tcontext@(TableContext tmap) <- get -- find the relevant table for the key to the right table - traceShowM ("insertColumn", colName) + traceShowM ("noteColumnMention", colName) tblAlias' <- case mTblAlias of Just tblAlias -> do void $ lookupTable tblAlias @@ -144,21 +178,21 @@ insertColumn mTblAlias colName mColAlias = do ColumnName [c] -> ColumnAlias c ColumnName [t,c] -> ColumnAlias (t <> "." <> c) Just al -> al - origColName = case colName of - ColumnName [c] -> c - ColumnName [_,c] -> c + origAttrName = case colName of + [c] -> c + [_,c] -> c {- when (newAlias `elem` allColumnAliases tcontext) $ do traceShowM ("gonk error", "colName", colName, "mTblAlias", mTblAlias, "mColAlias", mColAlias, - tmap) +p tmap) throwSQLE (DuplicateColumnAliasError newAlias)-} --duplicate column aliases are OK --verify that the alias is not duplicated let tmap' = M.adjust insertCol tblAlias' tmap insertCol (rvexpr, attrs, colMap) = - (rvexpr, attrs, M.insert newAlias origColName colMap) + (rvexpr, attrs, M.insert origAttrName (newAlias origColName colMap) put (TableContext tmap') pure newAlias @@ -196,14 +230,17 @@ lookupTable ta = do Nothing -> throwSQLE (MissingTableReferenceError ta) Just res -> pure res +{- -- | Merge table contexts (used in subselects) -mergeContext :: TableContext -> ConvertM () +mergeContext :: TableContext -> ConvertM ColumnAliasMap mergeContext (TableContext ctxB) = do (TableContext tMapA) <- get - foldM folder () (M.toList tMapA) + foldM folder mempty (M.toList tMapA) where - folder acc (tAlias, (re,attrs, _)) = insertTable tAlias re attrs - + folder acc (tAlias, (re,attrs, _)) = do + colMap <- insertTable tAlias re attrs + pure (M.union acc colMap) +-} -- | Find a column name or column alias in the underlying table context. Returns key into table context. findColumn :: ColumnName -> ConvertM [TableAlias] findColumn targetCol = do @@ -213,7 +250,7 @@ findColumn targetCol = do -- | non ConvertM version of findColumn findColumn' :: ColumnName -> TableContext -> [TableAlias] findColumn' targetCol (TableContext tMap) = do - traceShowM ("findColumn'", targetCol, tMap) +-- traceShowM ("findColumn'", targetCol, tMap) M.foldrWithKey folder [] tMap where folder tAlias@(TableAlias tat) (rvExpr, rtype, _) acc = @@ -251,17 +288,16 @@ findOneColumn' targetCol tcontext = do -- | Search the TableContext for a column alias remapping for the given column name. attributeNameForColumnName' :: ColumnName -> TableContext -> Either SQLError AttributeName attributeNameForColumnName' colName tcontext@(TableContext tmap) = do - traceShowM ("attributeNameForColumnName'", colName) --- traceShowM ("attribtueNameForColumnName tmap", tmap) tKey@(TableAlias tAlias) <- findOneColumn' colName tcontext let (_, rvattrs, colAliases) = tmap M.! tKey --strip table prefix, if necessary colAlias@(ColumnAlias colAttr) <- case colName of ColumnName [attr] -> pure $ ColumnAlias attr ColumnName [tname,attr] -> pure $ ColumnAlias (tname <> "." <> attr) - ColumnName{} -> traceShow ("attrname", colName) $ Left $ ColumnResolutionError colName + ColumnName{} -> Left $ ColumnResolutionError colName + traceShowM ("attributeNameForColumnName' colAlias", colAliases, colAlias) case M.lookup colAlias colAliases of - Just _ -> pure (unColumnAlias colAlias) -- we found it, so it's valid + Just res -> pure res -- we found it, so it's valid Nothing -> -- look in rvattrs, so we don't need the table alias prefix. The lack of an entry in the column alias map indicates that the column was not renamed in the join condition. if colAttr `A.isAttributeNameContained` rvattrs then @@ -277,11 +313,12 @@ attributeNameForColumnName' colName tcontext@(TableContext tmap) = do attributeNameForColumnName :: ColumnName -> ConvertM AttributeName attributeNameForColumnName colName = do s <- get - traceShowM ("attributeNameForColumnName", colName) - traceStateM case attributeNameForColumnName' colName s of Left err -> throwSQLE err - Right al -> pure al + Right al -> do + traceStateM + traceShowM ("attributeNameForColumnName", colName, "->", al) + pure al wrapTypeF :: TypeForRelExprF -> RelationalExpr -> ConvertM Relation @@ -343,10 +380,13 @@ convertSelect typeF sel = do let withF = case withAssocs of [] -> id _ -> With withAssocs + finalRelExpr = explicitWithF (withF (projF (convertExpr dfExpr))) -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes s <- get traceStateM - pure (dfExpr { convertExpr = explicitWithF (withF (projF (convertExpr dfExpr))) }) + -- apply rename reduction- this could be applied by the static query optimizer, but we do it here to simplify the tests so that they aren't polluted with redundant renames + pure (dfExpr { convertExpr = finalRelExpr }) + -- returns a new typeF function which adds type checking for "with" clause expressions appendWithsToTypeF :: TypeForRelExprF -> WithNamesAssocs -> TypeForRelExprF @@ -367,11 +407,11 @@ convertSubSelect typeF sel = do Just wClause -> do convertWithClause typeF wClause let typeF' = appendWithsToTypeF typeF wExprs - (dfExpr, colRemap) <- case tableExpr sel of + (dfExpr, colMap) <- case tableExpr sel of Nothing -> pure (baseDFExpr, mempty) Just tExpr -> convertTableExpr typeF' tExpr when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") - traceShowM ("convertSubSelect", colRemap) + traceShowM ("convertSubSelect", colMap) let explicitWithF = if null wExprs then id else With wExprs -- convert projection using table alias map to resolve column names projF <- convertProjection typeF' (projectionClause sel) -- the projection can only project on attributes from the subselect table expression @@ -381,8 +421,6 @@ convertSubSelect typeF sel = do [] -> id _ -> With withAssocs -- add disambiguation renaming --- tableColumns = foldr ((\(tname,(_,_,colAliases)) acc -> acc <> map () (M.) [] (M.toList aliasDiff) --- renamesSet <- foldM (\acc pure (explicitWithF (withF (projF (convertExpr dfExpr)))) traceShowM ("diff", aliasDiff) -- alias is not correct- the col alias map is empty for subquery pure ret @@ -423,7 +461,7 @@ convertSelectItem typeF acc (c,selItem) = } where colinfo (ColumnProjectionName [ProjectionName name]) = do - findOneColumn (traceShow ("colinfo", name) (ColumnName [name])) + findOneColumn (ColumnName [name]) convertProjection :: TypeForRelExprF -> [SelectItem] -> ConvertM (RelationalExpr -> RelationalExpr) convertProjection typeF selItems = do @@ -456,21 +494,11 @@ convertProjection typeF selItems = do let fRenames = if S.null renamesSet then id else Rename renamesSet pure (fProjection . fExtended . fRenames) -{- -convertColumnProjectionName :: ColumnProjectionName -> Either SQLError AttributeName -convertColumnProjectionName (ColumnProjectionName names) = do - let namer (ProjectionName t) = pure t - namer Asterisk = Left (NotSupportedError "asterisk in projection conversion") - names' <- mapM namer names - pure (T.concat names') --} - convertUnqualifiedColumnName :: UnqualifiedColumnName -> AttributeName convertUnqualifiedColumnName (UnqualifiedColumnName nam) = nam convertColumnName :: ColumnName -> ConvertM AttributeName convertColumnName colName = do - traceShowM ("convertColumnName", colName) attributeNameForColumnName colName convertColumnProjectionName :: ColumnProjectionName -> ConvertM AttributeName @@ -481,20 +509,31 @@ convertColumnProjectionName qpn@(ColumnProjectionName names) = do convertColumnName (ColumnName names') -convertTableExpr :: TypeForRelExprF -> TableExpr -> ConvertM (DataFrameExpr, ColumnRemap) +convertTableExpr :: TypeForRelExprF -> TableExpr -> ConvertM (DataFrameExpr, ColumnAliasMap) convertTableExpr typeF tExpr = do - (fromExpr, columnRemap) <- convertFromClause typeF (fromClause tExpr) - expr' <- case whereClause tExpr of + (fromExpr, columnMap) <- convertFromClause typeF (fromClause tExpr) + whereF <- case whereClause tExpr of Just whereExpr -> do restrictPredExpr <- convertWhereClause typeF whereExpr - pure $ Restrict restrictPredExpr fromExpr - Nothing -> pure fromExpr + pure $ Restrict restrictPredExpr + Nothing -> pure id orderExprs <- convertOrderByClause typeF (orderByClause tExpr) - let dfExpr = DataFrameExpr { convertExpr = expr', + -- add disambiguation renaming + let disambiguationRenamerF = if S.null renames then id else Rename renames + renames = S.fromList $ foldr folder mempty (M.toList columnMap) + whereAttrNames = S.map (\(ColumnName cs) -> T.intercalate "." cs) whereColNames + whereColNames = maybe mempty columnNamesInRestrictionExpr (whereClause tExpr) + folder (ColumnAlias alias, attrName) acc = -- include renamer only if the column is referenced and the renaming is not redundant + if alias /= attrName && S.member alias whereAttrNames then + (attrName, alias):acc + else + acc + + let dfExpr = DataFrameExpr { convertExpr = whereF (disambiguationRenamerF fromExpr), orderExprs = orderExprs, offset = offsetClause tExpr, limit = limitClause tExpr } - pure (dfExpr, columnRemap) + pure (dfExpr, columnMap) convertWhereClause :: TypeForRelExprF -> RestrictionExpr -> ConvertM RestrictionPredicateExpr convertWhereClause typeF (RestrictionExpr rexpr) = do @@ -506,7 +545,6 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do StringLiteral{} -> wrongType TextAtomType Identifier i -> wrongType TextAtomType -- could be a better error here BinaryOperator i@(Identifier colName) (OperatorName ["="]) exprMatch -> do --we don't know here if this results in a boolean expression, so we pass it down - traceShowM ("= bin", colName) attrName <- attributeNameForColumnName colName AttributeEqualityPredicate attrName <$> convertScalarExpr typeF exprMatch BinaryOperator exprA op exprB -> do @@ -529,7 +567,7 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do NotIn -> pure (NotPredicate res) ExistsExpr subQ -> do relExpr <- convertSubSelect typeF subQ - --pretty sure I have to rename attributes in both the top-level query and in this one to prevent attribute conflicts- we can't rename all the attributes in the subquery, because the renamer won't know which attributes actually refer to the top-level attributes- should we just prefix all attributes unconditionally or send a signal upstream to rename attributes? + --pretty sure I have to rename attributes in both the top-level query and in this one to prevent attribute conflicts- we can't rename all the attributes in the subquery, because the renamer won't know which attributes actually refer to the top-level attributes- should we just prefix all attributes unconditionally or send a signal upstream to rename attributes? FIXME let rexpr = Project A.empty relExpr pure (RelationalExprPredicate rexpr) @@ -544,7 +582,6 @@ convertScalarExpr typeF expr = do -- we don't have enough type context with a cast, so we default to text NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) Identifier i -> do - traceShowM ("convertScalarExpr", i) AttributeAtomExpr <$> convertColumnName i BinaryOperator exprA op exprB -> do a <- convertScalarExpr typeF exprA @@ -597,22 +634,22 @@ convertWithClause typeF wClause = type ColumnRemap = M.Map ColumnName ColumnName -convertFromClause :: TypeForRelExprF -> [TableRef] -> ConvertM (RelationalExpr, ColumnRemap) +convertFromClause :: TypeForRelExprF -> [TableRef] -> ConvertM (RelationalExpr, ColumnAliasMap) convertFromClause typeF (firstRef:trefs) = do --the first table ref must be a straight RelationVariable let convertFirstTableRef (SimpleTableRef (TableName [nam])) = do let rv = RelationVariable nam () typeR <- wrapTypeF typeF rv - insertTable (TableAlias nam) rv (attributes typeR) - pure rv + colMap <- insertTable (TableAlias nam) rv (attributes typeR) + pure (rv, colMap) convertFirstTableRef (AliasedTableRef (SimpleTableRef (TableName [nam])) al@(TableAlias alias)) = do let rv = RelationVariable nam () typeR <- wrapTypeF typeF rv - insertTable al rv (attributes typeR) - pure (RelationVariable alias ()) - firstRel <- convertFirstTableRef firstRef + colMap <- insertTable al rv (attributes typeR) + pure (RelationVariable alias (), colMap) + (firstRel, colMap) <- convertFirstTableRef firstRef expr' <- foldM (joinTableRef typeF) firstRel (zip [1..] trefs) - pure (expr', mempty {- FIXME add column remapping-}) + pure (expr', colMap) -- | Convert TableRefs after the first one (assumes all additional TableRefs are for joins). Returns the qualified name key that was added to the map, the underlying relexpr (not aliased so that it can used for extracting type information), and the new table context map convertTableRef :: TypeForRelExprF -> TableRef -> ConvertM (TableAlias, RelationalExpr) @@ -645,11 +682,11 @@ joinTableRef typeF rvA (c,tref) = do prefixOneAttr tAlias@(TableAlias prefix) old_name = do -- insert into columnAliasMap let new_name = T.concat [prefix, ".", old_name] - traceShowM ("prefixOneAttr", tAlias, old_name, new_name) +-- traceShowM ("prefixOneAttr", tAlias, old_name, new_name) addColumnAlias tAlias (ColumnAlias new_name) old_name pure (old_name, new_name) renameOneAttr x expr old_name = do - traceShowM ("renameOneAttr", old_name, new_name) +-- traceShowM ("renameOneAttr", old_name, new_name) addColumnAlias (TableAlias prefix) (ColumnAlias new_name) old_name pure (old_name, new_name) where @@ -718,16 +755,10 @@ joinTableRef typeF rvA (c,tref) = do -- rvPrefixB <- rvPrefix rvB exprA <- prefixRenamer (TableAlias rvNameA) rvA (S.toList attrsA) exprB <- prefixRenamer tKey (RelationVariable rvNameB ()) (S.toList attrsB) - traceShowM ("exprA", exprA) - traceShowM ("exprB", exprB) +-- traceShowM ("exprA", exprA) +-- traceShowM ("exprB", exprB) -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition tcontext <- get -{- let joinExpr' = renameIdentifier renamer joinExpr - renamer colName = - case attributeNameForColumnName' (traceShow ("inner join", colName) colName) tcontext of - Left err -> error (show err) - Right attrName -> (ColumnName [attrName]) - traceShowM ("joinExpr'", joinExpr')-} joinRe <- convertScalarExpr typeF joinExpr --' why are we renaming here- can't we call attributenameforcolumnname in the scalarexpr conversion??? --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name = --rename all common attrs and use the new names in the join condition @@ -790,6 +821,17 @@ renameIdentifier renamer sexpr = Fold.cata renamer' sexpr renamer' (IdentifierF n) = Identifier (renamer n) renamer' x = Fold.embed x +-- find all column aliases in a scalar expression- useful for determining if a renamer needs to be applied +columnNamesInScalarExpr :: ScalarExpr -> S.Set ColumnName +columnNamesInScalarExpr expr = Fold.cata finder expr + where + finder :: ScalarExprBaseF ColumnName (S.Set ColumnName) -> S.Set ColumnName + finder (IdentifierF n) = S.singleton n + finder exprs = foldr S.union mempty exprs + +columnNamesInRestrictionExpr :: RestrictionExpr -> S.Set ColumnName +columnNamesInRestrictionExpr (RestrictionExpr sexpr) = columnNamesInScalarExpr sexpr + -- | If the restriction includes a EXISTS expression, we must rename all attributes at the top-level to prevent conflicts. needsToRenameAllAttributes :: RestrictionExpr -> Bool needsToRenameAllAttributes (RestrictionExpr sexpr) = @@ -812,4 +854,9 @@ needsToRenameAllAttributes (RestrictionExpr sexpr) = InExpr _ sexpr _ -> rec' sexpr BooleanOperatorExpr e1 _ e2 -> rec' e1 || rec' e2 ExistsExpr{} -> True - + +{- +:showexpr relation{tuple{val 4, children relation{tuple{val 6,children relation{tuple{}}}}}, + tuple{val 10, children relation{tuple{val 1, children relation{tuple{}}}, + tuple{val 2, children relation{tuple{}}}}}} +-} diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index 569bd026..ed2c039c 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -19,6 +19,8 @@ import Control.Monad.Trans.Except import Data.Functor.Identity import qualified Data.Map as M import qualified Data.Set as S +import Data.Functor.Foldable as Fold +import Debug.Trace -- the static optimizer performs optimizations which need not take any specific-relation statistics into account @@ -575,6 +577,26 @@ applyStaticRestrictionPushdown expr = case expr of NotEquals (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2) Extend n sub -> Extend n (applyStaticRestrictionPushdown sub) + +-- if the rename is completely redundant because it renames an attribute name to the same attribute name, remove it +-- Rename [(x,x)] == Rename [] +applyRedundantRenameCleanup :: GraphRefRelationalExpr -> GraphRefRelationalExpr +applyRedundantRenameCleanup expr = Fold.cata folder expr + where + folder (RenameF renameSet e) = + if S.null renameSet then + e + else + Rename (S.filter (\(a,b) -> a /= b) renameSet) e + folder e = Fold.embed e +-- if the destination name in the rename is unused, we can remove it- does not detect errors if an a Rename is missing +-- Project ["x"] (Rename [("y","z"),("w","x")] (RelationVariable "rv" ())) == Project ["x"] (Rename [("w","x")] (RelationVariable "rv" ())) +applyUnusedRenameCleanup :: Show a => RelationalExprBase a -> RelationalExprBase a +applyUnusedRenameCleanup expr = Fold.para folder expr + where + folder :: Show a => RelationalExprBaseF a (RelationalExprBase a, RelationalExprBase a) -> RelationalExprBase a + folder (RenameF renameSet (expr', acc)) = traceShow ("para", expr', acc) (Rename renameSet expr') + folder e = traceShow ("para2", Fold.embed $ fst <$> e) $ Fold.embed $ fst <$> e -- no optimizations available optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 5d18bd8b..e4dc4f70 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -45,7 +45,7 @@ testSelect = TestCase $ do (tgraph,transId) <- freshTransactionGraph dateExamples (sess, conn) <- dateExamplesConnection emptyNotificationCallback - let readTests = [ + let readTests = [{- -- simple relvar ("SELECT * FROM s", "(s)"), -- simple projection @@ -54,10 +54,10 @@ testSelect = TestCase $ do ("SELECT city FROM s where status=20","((s where status=20){city})"), -- restriction with asterisk and qualified name ("SELECT * FROM s WHERE \"s\".\"status\"=20","(s where status=20)"), - -- join via where clause + -- join via where clause-} ("SELECT city FROM s, sp where \"s\".\"s#\" = \"sp\".\"s#\"", "((((s rename {s# as `s.s#`}) join sp) where `s.s#` = @s#){city})" - ), + ){-, -- restriction ("SELECT status,city FROM s where status>20","((s where gt(@status,20)){status,city})"), -- extension mixed with projection @@ -124,7 +124,7 @@ testSelect = TestCase $ do -- where exists -- complication: we need to add attribute renamers due to the subselect ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s\".\"s#\"=\"sp\".\"s#\")", - "((s rename {s# as `s.s#`}) where (((sp rename {s# as `sp.s#`}) where `s.s#`= @`sp.s#`){}))") + "(s where (((sp rename {s# as `sp.s#`}) where `s#`= @`sp.s#`){}))")-} ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, From 79d1e34792b7380cb4918e2ec0ae4fcd23266bbd Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 29 Dec 2023 21:28:41 -0500 Subject: [PATCH 021/170] peg streamly at 0.9.0 (0.10.0 not yet supported due to API changes) fix reading and writing notifications previously, notifications were associated with client connections which are transient so we did not write them as part of transaction data YuMingLiao discovered that the notifications were not restored upon database loading because they were always assigned mempty leading to merkle hash validation failure because notifications are sent to all connected clients, this fix read and writes notifications as any other transaction data thereby fixing the merkle hash validation --- project-m36.cabal | 4 ++-- src/lib/ProjectM36/HashSecurely.hs | 1 - src/lib/ProjectM36/Transaction/Persist.hs | 20 +++++++++++++++++++- test/TransactionGraph/Persist.hs | 8 ++++---- 4 files changed, 25 insertions(+), 8 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index 25aafcb0..50ad8d0b 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 0.9.7 +Version: 0.9.8 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple @@ -35,7 +35,7 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.8 && < 4.17, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.2.2, network, async, vector-instances, recursion-schemes, streamly >= 0.7.2, convertible, fast-builder, scientific, time-compat >= 1.9.6.1 + Build-Depends: base>=4.8 && < 4.17, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.2.2, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific, time-compat >= 1.9.6.1 if flag(haskell-scripting) Build-Depends: ghc >= 8.2 && < 9.3 CPP-Options: -DPM36_HASKELL_SCRIPTING diff --git a/src/lib/ProjectM36/HashSecurely.hs b/src/lib/ProjectM36/HashSecurely.hs index 78ef62ad..91d53e0e 100644 --- a/src/lib/ProjectM36/HashSecurely.hs +++ b/src/lib/ProjectM36/HashSecurely.hs @@ -25,7 +25,6 @@ import qualified Data.Set as S import Data.Time.Calendar import Data.Time.Clock import Codec.Winery (Serialise) -import Data.Int (Int64) newtype SecureHash = SecureHash { _unSecureHash :: B.ByteString } deriving (Serialise, Show, Eq) diff --git a/src/lib/ProjectM36/Transaction/Persist.hs b/src/lib/ProjectM36/Transaction/Persist.hs index 9b1f8043..bdc12063 100644 --- a/src/lib/ProjectM36/Transaction/Persist.hs +++ b/src/lib/ProjectM36/Transaction/Persist.hs @@ -45,6 +45,9 @@ transactionDir dbdir transId = dbdir show transId transactionInfoPath :: FilePath -> FilePath transactionInfoPath transdir = transdir "info" +notificationsPath :: FilePath -> FilePath +notificationsPath transdir = transdir "notifs" + relvarsPath :: FilePath -> FilePath relvarsPath transdir = transdir "relvars" @@ -82,13 +85,14 @@ readTransaction dbdir transId mScriptSession = do incDeps <- readIncDeps transDir typeCons <- readTypeConstructorMapping transDir sschemas <- readSubschemas transDir + notifs <- readNotifications transDir dbcFuncs <- readFuncs transDir (dbcFuncsPath transDir) basicDatabaseContextFunctions mScriptSession atomFuncs <- readFuncs transDir (atomFuncsPath transDir) precompiledAtomFunctions mScriptSession registeredQs <- readRegisteredQueries transDir let newContext = DatabaseContext { inclusionDependencies = incDeps, relationVariables = relvars, typeConstructorMapping = typeCons, - notifications = M.empty, + notifications = notifs, atomFunctions = atomFuncs, dbcFunctions = dbcFuncs, registeredQueries = registeredQs } @@ -108,6 +112,7 @@ writeTransaction sync dbdir trans = do writeIncDeps sync tempTransDir (inclusionDependencies context) writeFuncs sync (atomFuncsPath tempTransDir) (HS.toList (atomFunctions context)) writeFuncs sync (dbcFuncsPath tempTransDir) (HS.toList (dbcFunctions context)) + writeNotifications sync tempTransDir (notifications context) writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context) writeSubschemas sync tempTransDir (subschemas trans) writeRegisteredQueries sync tempTransDir (registeredQueries context) @@ -280,3 +285,16 @@ writeRegisteredQueries :: DiskSync -> FilePath -> RegisteredQueries -> IO () writeRegisteredQueries sync transDir regQs = do let regQsPath = registeredQueriesPath transDir traceBlock "write registered queries" $ writeSerialiseSync sync regQsPath regQs + +readNotifications :: FilePath -> IO Notifications +readNotifications transDir = do + let notifsPath = notificationsPath transDir + readFileDeserialise notifsPath + +writeNotifications :: DiskSync -> FilePath -> Notifications -> IO () +writeNotifications sync transDir notifs = do + let notifsPath = notificationsPath transDir + traceBlock "write notifications" $ writeSerialiseSync sync notifsPath notifs + + + diff --git a/test/TransactionGraph/Persist.hs b/test/TransactionGraph/Persist.hs index 8fdc50d2..4f60264a 100644 --- a/test/TransactionGraph/Persist.hs +++ b/test/TransactionGraph/Persist.hs @@ -31,7 +31,6 @@ testList = TestList [testBootstrapDB, testDBSimplePersistence, testFunctionPersistence, testMerkleHashValidation] - stamp' :: UTCTime stamp' = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000) @@ -85,6 +84,9 @@ testMerkleHashValidation = TestCase $ conn <- assertIOEither $ connectProjectM36 connInfo sess <- assertIOEither $ createSessionAtHead conn "master" Right _ <- executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) + -- add a notification because we forgot to read/write it as part of the transaction before + let relX = RelationVariable "x" () + Right _ <- executeDatabaseContextExpr sess conn (AddNotification "testnotif" relX relX relX) Right _ <- commit sess conn val <- C.validateMerkleHashes sess conn assertEqual "merkle success" (Right ()) val @@ -130,8 +132,6 @@ testMerkleHashValidation = TestCase $ assertEqual "open connection merkle validation" (DatabaseValidationError [MerkleValidationError (transactionId trans) regMerkleHash malMerkleHash]) err Right _ -> assertFailure "open connection validation" - - --only Haskell-scripted dbc and atom functions can be serialized testFunctionPersistence :: Test #if !defined(PM36_HASKELL_SCRIPTING) @@ -159,7 +159,7 @@ testFunctionPersistence = TestCase $ let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]] assertEqual "testdisk dbc function run" expectedRel res -#endif +#endif assertIOEither :: (Show a) => IO (Either a b) -> IO b assertIOEither x = do From e3848ad0280ec3bee0b0f4e822a47081f14eacbd Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 29 Dec 2023 23:08:20 -0500 Subject: [PATCH 022/170] upgrade streamly dependencies in nix --- nix/sources.json | 12 ------------ release.nix | 9 +++++++-- 2 files changed, 7 insertions(+), 14 deletions(-) diff --git a/nix/sources.json b/nix/sources.json index 82466623..5375af71 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -34,17 +34,5 @@ "type": "tarball", "url": "https://github.com/NixOS/nixpkgs/archive/429c23aad0fce9ef38b0e60d55d7459c19d53ddc.tar.gz", "url_template": "https://github.com///archive/.tar.gz" - }, - "streamly": { - "branch": "ac3af8749194f1788704dda8667d0b3807075cc2", - "description": "Beautiful Streaming, Concurrent and Reactive Composition (Haskell)", - "homepage": "https://hackage.haskell.org/package/streamly", - "owner": "composewell", - "repo": "streamly", - "rev": "ac3af8749194f1788704dda8667d0b3807075cc2", - "sha256": "04d8fk654vawdfs0dfidmq2awwgwi8x44iv8r7vqz70zkcsd5fij", - "type": "tarball", - "url": "https://github.com/composewell/streamly/archive/ac3af8749194f1788704dda8667d0b3807075cc2.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" } } diff --git a/release.nix b/release.nix index 49e3de7b..da486623 100644 --- a/release.nix +++ b/release.nix @@ -20,8 +20,13 @@ let streamly = self.callHackageDirect { pkg = "streamly"; - ver = "0.8.1"; - sha256 = "0ywyy7gxjnp32hx8kki0lfn94bnc9mzjh8g6mg65ff3vv28k2vdr"; } {}; + ver = "0.9.0"; + sha256 = "sha256-eOxVb8qQjZDo1+S7CStqYSExOg2QHWkMY+zlOYqwZak="; } {}; + + streamly-core = self.callHackageDirect { + pkg = "streamly-core"; + ver = "0.1.0"; + sha256 = "sha256-hoSV6Q2+X5a7hFnJAArqNPjcMaCVyX9Vz4FcxeJ+jgI="; } {}; unicode-data = self.callHackageDirect { pkg = "unicode-data"; From 61b03cc7f57d8be196e91ee5e0efa4fc19a497af Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 29 Dec 2023 23:07:54 -0500 Subject: [PATCH 023/170] drop support for stack with GHC 8.10 and 9.0 due to incompatible streamly-bytestring due to curryer-rpc upgrade --- .github/workflows/ci.yaml | 4 +--- stack.ghc8.10.yaml | 22 ---------------------- stack.ghc9.0.yaml | 20 -------------------- stack.ghc9.2.yaml | 6 ++++-- 4 files changed, 5 insertions(+), 47 deletions(-) delete mode 100644 stack.ghc8.10.yaml delete mode 100644 stack.ghc9.0.yaml diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 5cb0c9a9..f59601c1 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -35,12 +35,10 @@ jobs: matrix: os: [ubuntu-latest] ghc: - - ghc8.10 - - ghc9.0 - ghc9.2 include: - os: macos-latest - ghc: ghc8.10 + ghc: ghc9.2 env: STACK_YAML: stack.${{ matrix.ghc }}.yaml steps: diff --git a/stack.ghc8.10.yaml b/stack.ghc8.10.yaml deleted file mode 100644 index 5223d6b5..00000000 --- a/stack.ghc8.10.yaml +++ /dev/null @@ -1,22 +0,0 @@ -resolver: lts-18.20 -packages: - - "." - -extra-deps: - - streamly-0.8.1 - - curryer-rpc-0.2.2 - - fast-builder-0.1.2.1 - - rset-1.0.0 - - winery-1.4 - - barbies-th-0.1.8 - - base16-bytestring-1.0.1.0 - - unicode-data-0.2.0 - - stm-containers-1.2 - - stm-hamt-1.2.0.7 - - time-compat-1.9.6.1 - - hashable-1.3.2.0 - -flags: - project-m36: - stack: true -# allow-newer: true diff --git a/stack.ghc9.0.yaml b/stack.ghc9.0.yaml deleted file mode 100644 index db9435f7..00000000 --- a/stack.ghc9.0.yaml +++ /dev/null @@ -1,20 +0,0 @@ -resolver: lts-19.19 -packages: - - "." - -extra-deps: - - streamly-0.8.2 - - curryer-rpc-0.2.2 - - fast-builder-0.1.2.1 - - rset-1.0.0 - - winery-1.4 - - barbies-th-0.1.10 - - base16-bytestring-1.0.2.0 - - unicode-data-0.2.0 - - stm-containers-1.2 - - stm-hamt-1.2.0.7 - -flags: - project-m36: - stack: true -allow-newer: true diff --git a/stack.ghc9.2.yaml b/stack.ghc9.2.yaml index 4773b903..659a4b7e 100644 --- a/stack.ghc9.2.yaml +++ b/stack.ghc9.2.yaml @@ -3,8 +3,10 @@ packages: - "." extra-deps: - - streamly-0.8.2 - - curryer-rpc-0.2.2 + - streamly-0.9.0 + - streamly-core-0.1.0 + - streamly-bytestring-0.2.0 + - curryer-rpc-0.3.1 - fast-builder-0.1.2.1 - rset-1.0.0 - winery-1.4 From dc827257f6fb5b1ebbad1fe6127028b93978a145 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 30 Dec 2023 01:49:55 -0500 Subject: [PATCH 024/170] upgrade lockfree-queue in nix upgrade nixpkgs upgrade GHC in docker image creation to 9.2.8 due to module conflict --- nix/sources.json | 6 +++--- release.nix | 18 ++++++++++++------ 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/nix/sources.json b/nix/sources.json index 5375af71..07bf54af 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -29,10 +29,10 @@ "homepage": "", "owner": "NixOS", "repo": "nixpkgs", - "rev": "429c23aad0fce9ef38b0e60d55d7459c19d53ddc", - "sha256": "1nj8sh1fnxp07jdlvjkijwfd1pnsi2zj0ivy7a0dhx02g63byhg3", + "rev": "9fafaa30660e204bb27a35b3c608f03609705a5d", + "sha256": "sha256:0ijw5yvglmh1kicxdailn0hvv2lbwbwgs9p9dshnxv0pvgvqi433", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/429c23aad0fce9ef38b0e60d55d7459c19d53ddc.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/9fafaa30660e204bb27a35b3c608f03609705a5d.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } diff --git a/release.nix b/release.nix index da486623..398e53e0 100644 --- a/release.nix +++ b/release.nix @@ -1,4 +1,4 @@ -{ compiler ? "ghc8104" +{ compiler ? "ghc928" , sources ? import ./nix/sources.nix , pkgs ? import sources.nixpkgs { } }: @@ -28,6 +28,12 @@ let ver = "0.1.0"; sha256 = "sha256-hoSV6Q2+X5a7hFnJAArqNPjcMaCVyX9Vz4FcxeJ+jgI="; } {}; + lockfree-queue = self.callHackageDirect { + pkg = "lockfree-queue"; + ver = "0.2.4"; + sha256 = "sha256-h1s/tiBq5Gzl8FtenQacmxJp7zPJPnmZXtKDPvxTSa4="; } {}; + + unicode-data = self.callHackageDirect { pkg = "unicode-data"; ver = "0.2.0"; @@ -46,11 +52,11 @@ let sha256 = "sha256-2pXGgM5n2hKh2gvKhGJMKzAwWMEn6KUUz8i5n3pHakY="; } {}; - hashable = self.callHackageDirect { - pkg = "hashable"; - ver = "1.3.2.0"; - sha256 = "sha256-aMtNQNykvenduMW99h0ZDuU4kI1fFbIY4m4rRRNAU9o="; - } {}; + barbies-th = self.callHackageDirect { + pkg = "barbies-th"; + ver = "0.1.10"; + sha256 = "sha256-cnTevB2qoEBMmGbqypQwJzPVF6z3cOXADbWF8OKQGAo="; + } {}; project-m36 = ((self.callCabal2nixWithOptions "project-m36" ./. "-f-haskell-scripting" {})); }; From df1ea5410fedf81a6dc10e79076eb12c7de8f186 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 30 Dec 2023 01:59:40 -0500 Subject: [PATCH 025/170] upgrade GHC for docker nix to 9.2.8 --- docker.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docker.nix b/docker.nix index 6887e0f4..f371b6a1 100644 --- a/docker.nix +++ b/docker.nix @@ -1,4 +1,4 @@ -{ compiler ? "ghc8104" +{ compiler ? "ghc928" , sources ? import ./nix/sources.nix , pkgs ? import sources.nixpkgs { } }: From e18ca94da403af2ae7e77274ed1f77a4df237c75 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 30 Dec 2023 10:03:44 -0500 Subject: [PATCH 026/170] make GHC 9.2 the least version of support GHC remove time-compat dependency due to various module conflicts --- docs/15_minute_tutorial.markdown | 2 +- docs/dev_setup.markdown | 4 ++-- project-m36.cabal | 2 +- release.nix | 10 ++-------- src/lib/ProjectM36/Base.hs | 14 ++++++++++++-- 5 files changed, 18 insertions(+), 14 deletions(-) diff --git a/docs/15_minute_tutorial.markdown b/docs/15_minute_tutorial.markdown index bd4b97e4..7e8123a1 100644 --- a/docs/15_minute_tutorial.markdown +++ b/docs/15_minute_tutorial.markdown @@ -12,7 +12,7 @@ Run a pre-built docker image: ```docker run -it projectm36/project-m36 tutd``` -or build it yourself with GHC >= 8.10: +or build it yourself with GHC >= 9.2: ```bash git clone https://github.com/agentm/project-m36.git diff --git a/docs/dev_setup.markdown b/docs/dev_setup.markdown index de0a47e5..f603943d 100644 --- a/docs/dev_setup.markdown +++ b/docs/dev_setup.markdown @@ -1,6 +1,6 @@ # Developer Setup -Project:M36 is developed in Haskell with GHC 8.8+ and stack or cabal. Project:M36 includes server and client executables, a test suite, and example programs. See [project-m36.cabal](https://github.com/agentm/project-m36/blob/master/project-m36.cabal) for the available options. +Project:M36 is developed in Haskell with GHC 9.2+ and stack or cabal. Project:M36 includes server and client executables, a test suite, and example programs. See [project-m36.cabal](https://github.com/agentm/project-m36/blob/master/project-m36.cabal) for the available options. ## cabal @@ -17,7 +17,7 @@ cabal new-run tutd Use [`stack`](https://docs.haskellstack.org/en/stable/README/) to build and run `tutd`. ``` -stack --stack-yaml=stack.ghc.8.10.yaml run tutd +stack --stack-yaml=stack.ghc.9.2.yaml run tutd ``` ## VSCode diff --git a/project-m36.cabal b/project-m36.cabal index 50ad8d0b..184c4c2e 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -35,7 +35,7 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.8 && < 4.17, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.2.2, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific, time-compat >= 1.9.6.1 + Build-Depends: base>=4.16 && < 4.17, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.2.2, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific if flag(haskell-scripting) Build-Depends: ghc >= 8.2 && < 9.3 CPP-Options: -DPM36_HASKELL_SCRIPTING diff --git a/release.nix b/release.nix index 398e53e0..fb4f84ad 100644 --- a/release.nix +++ b/release.nix @@ -15,8 +15,8 @@ let overrides = self: super: { curryer-rpc = self.callHackageDirect { pkg = "curryer-rpc"; - ver = "0.2.2"; - sha256 = "sha256-c4DgpJV3GZl2oW55RR56xps4lGuwTFQzYrJP8VeLLds="; } {}; + ver = "0.3.1"; + sha256 = "sha256-MJlj69pO6S3CkpTmm8UuNDwQ4tdoJHF0wl8QYXB/Vlw="; } {}; streamly = self.callHackageDirect { pkg = "streamly"; @@ -45,12 +45,6 @@ let ver = "1.4"; sha256 = "sha256-ApJg6Qc25UyNZtSN52N9OrUQ/9K4w258oSE5BokO4tE="; } {}; - #newer time-compat include hashable instances - time-compat = self.callHackageDirect { - pkg = "time-compat"; - ver = "1.9.6.1"; - sha256 = "sha256-2pXGgM5n2hKh2gvKhGJMKzAwWMEn6KUUz8i5n3pHakY="; - } {}; barbies-th = self.callHackageDirect { pkg = "barbies-th"; diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 3232c42f..8717b78b 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -20,8 +20,7 @@ import qualified Data.Vector as V import qualified Data.List as L import Data.Text (Text) import Data.Time.Clock -import Data.Time.Clock.Compat () -import Data.Time.Calendar (Day) +import Data.Time.Calendar (Day(..)) import Data.Typeable import Data.ByteString (ByteString) import qualified Data.List.NonEmpty as NE @@ -44,6 +43,17 @@ instance Hashable (S.Set AttributeName) where hashWithSalt salt s = salt `hashWithSalt` S.toList s #endif +-- time-compat includes these instances but time-compat is a dependency that is problematic, so just copy the instances here +instance Hashable Day where + hashWithSalt salt (ModifiedJulianDay d) = hashWithSalt salt d + +instance Hashable UTCTime where + hashWithSalt salt (UTCTime d dt) = + salt `hashWithSalt` d `hashWithSalt` dt + +instance Hashable DiffTime where + hashWithSalt salt = hashWithSalt salt . toRational + -- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys. data Atom = IntegerAtom !Integer | IntAtom !Int | From a659f31fc09b244c640002808969d6982135a732 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 30 Dec 2023 10:14:31 -0500 Subject: [PATCH 027/170] fix docker warning --- docker.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docker.nix b/docker.nix index f371b6a1..9f1e3b76 100644 --- a/docker.nix +++ b/docker.nix @@ -9,7 +9,7 @@ in pkgs.dockerTools.buildImage { name = "project-m36"; tag = "latest"; - contents = [ static-project-m36 ]; + copyToRoot = [ static-project-m36 ]; # expose default project-m36 and websocket server ports config = { Env = [ "LC_ALL=en_US.UTF-8" ]; From c796ffb255eac46ff126200a2658129a3374ea32 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 30 Dec 2023 20:41:15 -0500 Subject: [PATCH 028/170] add support for GHC 9.4 to CI update Changelog --- .github/workflows/ci.yaml | 1 + Changelog.markdown | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index f59601c1..7ad492fb 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -36,6 +36,7 @@ jobs: os: [ubuntu-latest] ghc: - ghc9.2 + - ghc9.4 include: - os: macos-latest ghc: ghc9.2 diff --git a/Changelog.markdown b/Changelog.markdown index fb439381..a1c92992 100644 --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,9 @@ +# 2023-12-30 (v0.9.8) + +* fix notification serialization in transaction (#362) +* require minimum GHC 9.2 (dropping GHC 8.10 and GHC 9.0) +* add support for GHC 9.4 + # 2023-07-18 (v0.9.7) * fix critical bug resulting in empty results from cross joins From bec1ccb9b7db9ab3d7893c3d765890f0a4b99ad5 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 30 Dec 2023 20:45:21 -0500 Subject: [PATCH 029/170] fix syntax in CI yaml update ScriptSession for GHC 9.4 --- .github/workflows/ci.yaml | 2 +- cabal.project | 2 +- project-m36.cabal | 10 +++++----- src/lib/ProjectM36/ScriptSession.hs | 21 +++++++++++++++++++-- 4 files changed, 26 insertions(+), 9 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 7ad492fb..117b8b56 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -36,7 +36,7 @@ jobs: os: [ubuntu-latest] ghc: - ghc9.2 - - ghc9.4 + - ghc9.4 include: - os: macos-latest ghc: ghc9.2 diff --git a/cabal.project b/cabal.project index 6bf8b77e..4a134cb0 100644 --- a/cabal.project +++ b/cabal.project @@ -5,4 +5,4 @@ package * split-sections: True -- allow fast-builder to build with GHC 9.2.2 (currently pegged at 9.0.1) -allow-newer: fast-builder:base +allow-newer: fast-builder:base, streamly-bytestring:bytestring diff --git a/project-m36.cabal b/project-m36.cabal index 184c4c2e..ed37dd52 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -35,9 +35,9 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.16 && < 4.17, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.2.2, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific + Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.2, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific if flag(haskell-scripting) - Build-Depends: ghc >= 8.2 && < 9.3 + Build-Depends: ghc >= 9.0 && < 9.5 CPP-Options: -DPM36_HASKELL_SCRIPTING if impl(ghc>= 8) && flag(haskell-scripting) build-depends: @@ -153,7 +153,7 @@ Library Executable tutd if flag(haskell-scripting) - Build-Depends: ghc >= 8.2 && < 9.3 + Build-Depends: ghc >= 9.0 && < 9.5 Build-Depends: base >=4.8, ghc-paths, project-m36, @@ -228,7 +228,7 @@ Executable tutd Executable project-m36-server if flag(haskell-scripting) - Build-Depends: ghc >= 8.2 && < 9.3 + Build-Depends: ghc >= 9.0 && < 9.5 Build-Depends: base, ghc-paths, transformers, @@ -421,7 +421,7 @@ Executable Example-Hair Executable Example-Plantfarm Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: aeson, barbies, base, binary, containers, deepseq, hashable, project-m36, random, scotty, text, winery + Build-Depends: aeson, barbies, base, containers, deepseq, hashable, project-m36, random, scotty, text, winery Main-Is: examples/Plantfarm.hs GHC-Options: -Wall -threaded diff --git a/src/lib/ProjectM36/ScriptSession.hs b/src/lib/ProjectM36/ScriptSession.hs index 5209e7a9..ee7dadb6 100644 --- a/src/lib/ProjectM36/ScriptSession.hs +++ b/src/lib/ProjectM36/ScriptSession.hs @@ -23,7 +23,18 @@ import System.Environment import Unsafe.Coerce import GHC.LanguageExtensions (Extension(OverloadedStrings,ExtendedDefaultRules,ImplicitPrelude,ScopedTypeVariables)) -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,4,0) +import GHC.Utils.Panic (handleGhcException) +import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) +import GHC.Types.SourceText (SourceText(NoSourceText)) +import GHC.Unit.Types (IsBootInterface(NotBoot)) +import GHC.Driver.Ppr (showSDocForUser) +import GHC.Core.Type (eqType) +import GHC.Core.TyCo.Ppr (pprType) +import GHC.Utils.Encoding (zEncodeString) +import GHC.Unit.State (emptyUnitState) +import GHC.Types.PkgQual (RawPkgQual(NoRawPkgQual)) +#elif MIN_VERSION_ghc(9,2,0) -- GHC 9.2.2 import GHC.Utils.Panic (handleGhcException) import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) @@ -168,7 +179,11 @@ initScriptSession ghcPkgPaths = do #else ideclName = noLoc (mkModuleName fullModuleName), #endif +#if MIN_VERSION_ghc(9,4,0) + ideclPkgQual = NoRawPkgQual, +#else ideclPkgQual = Nothing, +#endif #if MIN_VERSION_ghc(9,0,0) ideclSource = NotBoot, #else @@ -212,7 +227,9 @@ addImport moduleNam = do setContext (IIDecl (simpleImportDecl (mkModuleName moduleNam)) : ctx) showType :: DynFlags -> Type -> String -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,4,0) +showType dflags ty = showSDocForUser dflags emptyUnitState alwaysQualify (pprType ty) +#elif MIN_VERSION_ghc(9,2,0) showType dflags ty = showSDocForUser dflags emptyUnitState alwaysQualify (pprTypeForUser ty) #else showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty) From d967d1d324639c6dac9d3bf7920f8aab544d4bc7 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 30 Dec 2023 21:35:52 -0500 Subject: [PATCH 030/170] update stack yamls for GHC 9.2 and GHC 9.4 --- stack.ghc9.2.yaml | 4 ++-- stack.ghc9.4.yaml | 22 ++++++++++++++++++++++ 2 files changed, 24 insertions(+), 2 deletions(-) create mode 100644 stack.ghc9.4.yaml diff --git a/stack.ghc9.2.yaml b/stack.ghc9.2.yaml index 659a4b7e..b1cc4c6d 100644 --- a/stack.ghc9.2.yaml +++ b/stack.ghc9.2.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2022-08-19 +resolver: lts-20.26 packages: - "." @@ -6,7 +6,7 @@ extra-deps: - streamly-0.9.0 - streamly-core-0.1.0 - streamly-bytestring-0.2.0 - - curryer-rpc-0.3.1 + - curryer-rpc-0.3.2 - fast-builder-0.1.2.1 - rset-1.0.0 - winery-1.4 diff --git a/stack.ghc9.4.yaml b/stack.ghc9.4.yaml new file mode 100644 index 00000000..a59c8769 --- /dev/null +++ b/stack.ghc9.4.yaml @@ -0,0 +1,22 @@ +resolver: lts-21.0 +packages: + - "." + +extra-deps: + - streamly-0.9.0 + - streamly-core-0.1.0 + - streamly-bytestring-0.2.0 + - curryer-rpc-0.3.2 + - fast-builder-0.1.2.1 + - rset-1.0.0 + - winery-1.4 + - barbies-th-0.1.10 + - base16-bytestring-1.0.2.0 + - unicode-data-0.2.0 + - stm-containers-1.2 + - stm-hamt-1.2.0.7 + +flags: + project-m36: + stack: true +allow-newer: true From 245038e19027eb145106c4909b1f37f795be3e0c Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 30 Dec 2023 21:40:09 -0500 Subject: [PATCH 031/170] update nix with curryer-rpc 0.3.2 --- release.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/release.nix b/release.nix index fb4f84ad..1763708e 100644 --- a/release.nix +++ b/release.nix @@ -16,7 +16,7 @@ let curryer-rpc = self.callHackageDirect { pkg = "curryer-rpc"; ver = "0.3.1"; - sha256 = "sha256-MJlj69pO6S3CkpTmm8UuNDwQ4tdoJHF0wl8QYXB/Vlw="; } {}; + sha256 = "sha256-QiKsaFcIzOrtCpgVrgArnj7Hd09JVjF67huam+0aZSc="; } {}; streamly = self.callHackageDirect { pkg = "streamly"; From 926dfd912a7c2fa6fe6f1ec77160e26de93e1820 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 30 Dec 2023 21:51:48 -0500 Subject: [PATCH 032/170] update nix curryer-rpc to 0.3.2 correctly --- release.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/release.nix b/release.nix index 1763708e..22fb1e8a 100644 --- a/release.nix +++ b/release.nix @@ -15,7 +15,7 @@ let overrides = self: super: { curryer-rpc = self.callHackageDirect { pkg = "curryer-rpc"; - ver = "0.3.1"; + ver = "0.3.2"; sha256 = "sha256-QiKsaFcIzOrtCpgVrgArnj7Hd09JVjF67huam+0aZSc="; } {}; streamly = self.callHackageDirect { From 7e72f49d12b50805d8b82d1f4f302fe068864242 Mon Sep 17 00:00:00 2001 From: Yu-Ming Liao Date: Tue, 2 Jan 2024 15:29:51 +0800 Subject: [PATCH 033/170] WIP: non-empty list --- src/lib/ProjectM36/Atomable.hs | 5 ++++- test/Relation/Atomable.hs | 5 +++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/lib/ProjectM36/Atomable.hs b/src/lib/ProjectM36/Atomable.hs index 8243e4f0..a735fb27 100644 --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -21,6 +21,7 @@ import Data.Proxy import qualified Data.List.NonEmpty as NE import Codec.Winery import Data.UUID +import Debug.Trace -- | All database values ("atoms") adhere to the 'Atomable' typeclass. This class is derivable allowing new datatypes to be easily marshaling between Haskell values and database values. class (Eq a, NFData a, Serialise a, Show a) => Atomable a where @@ -159,7 +160,9 @@ instance Atomable a => Atomable [a] where instance Atomable a => Atomable (NE.NonEmpty a) where toAtom (x NE.:| []) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) [toAtom x] toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) (map toAtom (x:xs)) - fromAtom _ = error "improper fromAtom (NonEmptyList a)" + fromAtom (ConstructedAtom "NECons" _ [x]) = fromAtom x NE.:| [] + fromAtom (ConstructedAtom "NECons" t (x:y) ) = fromAtom x NE.:| fromAtom (ConstructedAtom "NECons" t y) + fromAtom x = trace (show x) $ error "improper fromAtom (NonEmptyList a)" toAtomType _ = ConstructedAtomType "NonEmptyList" (M.singleton "a" (toAtomType (Proxy :: Proxy a))) toAddTypeExpr _ = NoOperation diff --git a/test/Relation/Atomable.hs b/test/Relation/Atomable.hs index 792666d3..6456a003 100644 --- a/test/Relation/Atomable.hs +++ b/test/Relation/Atomable.hs @@ -13,6 +13,7 @@ import Data.Text import qualified Data.Map as M import Data.Proxy import Codec.Winery +import Data.List.NonEmpty {-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} data Test1T = Test1C Integer @@ -36,7 +37,7 @@ data TestListT = TestListC [Integer] deriving (Show, Generic, Eq, NFData, Atomable) deriving Serialise via WineryVariant TestListT -data TestNonEmptyT = TestNonEmptyC [Integer] +data TestNonEmptyT = TestNonEmptyC (NonEmpty Integer) deriving (Show, Generic, Eq, NFData, Atomable) deriving Serialise via WineryVariant TestNonEmptyT @@ -181,7 +182,7 @@ testSimpleList = TestCase $ do testNonEmptyInstance :: Test testNonEmptyInstance = TestCase $ do - let example = TestNonEmptyC [3,4,5] + let example = TestNonEmptyC (3 :| [4,5]) assertEqual "NonEmpty instance" example (fromAtom (toAtom example)) testNonPrimitiveValues :: Test From ce0faa3b3c0846558a0d47663698e87a1b3e1014 Mon Sep 17 00:00:00 2001 From: Yu-Ming Liao Date: Wed, 3 Jan 2024 11:47:42 +0800 Subject: [PATCH 034/170] fix fromAtom for NonEmptyList --- src/lib/ProjectM36/Atomable.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/lib/ProjectM36/Atomable.hs b/src/lib/ProjectM36/Atomable.hs index a735fb27..df696e16 100644 --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -21,7 +21,6 @@ import Data.Proxy import qualified Data.List.NonEmpty as NE import Codec.Winery import Data.UUID -import Debug.Trace -- | All database values ("atoms") adhere to the 'Atomable' typeclass. This class is derivable allowing new datatypes to be easily marshaling between Haskell values and database values. class (Eq a, NFData a, Serialise a, Show a) => Atomable a where @@ -159,10 +158,10 @@ instance Atomable a => Atomable [a] where instance Atomable a => Atomable (NE.NonEmpty a) where toAtom (x NE.:| []) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) [toAtom x] - toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) (map toAtom (x:xs)) + toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) (toAtom x : toAtom xs : []) fromAtom (ConstructedAtom "NECons" _ [x]) = fromAtom x NE.:| [] - fromAtom (ConstructedAtom "NECons" t (x:y) ) = fromAtom x NE.:| fromAtom (ConstructedAtom "NECons" t y) - fromAtom x = trace (show x) $ error "improper fromAtom (NonEmptyList a)" + fromAtom (ConstructedAtom "NECons" _ [x,y] ) = fromAtom x NE.:| fromAtom y + fromAtom x = error "improper fromAtom (NonEmptyList a)" toAtomType _ = ConstructedAtomType "NonEmptyList" (M.singleton "a" (toAtomType (Proxy :: Proxy a))) toAddTypeExpr _ = NoOperation From 02f1073bba75932da9bd5600c014612850c80397 Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 5 Jan 2024 13:03:29 -0500 Subject: [PATCH 035/170] wip fixing errors --- project-m36.cabal | 2 +- src/bin/SQL/Interpreter/Convert.hs | 29 +++++++++++++++++++++++------ 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index 7d9d7371..08c7e710 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -35,7 +35,7 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.8 && < 4.17, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.2.2, network, async, vector-instances, recursion-schemes, streamly >= 0.7.2, convertible, fast-builder, scientific, time-compat >= 1.9.6.1 + Build-Depends: base>=4.8 && < 4.17, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.2.3, network, async, vector-instances, recursion-schemes, streamly >= 0.7.2, convertible, fast-builder, scientific, time-compat >= 1.9.6.1 if flag(haskell-scripting) Build-Depends: ghc >= 8.2 && < 9.3 CPP-Options: -DPM36_HASKELL_SCRIPTING diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 5937e2cf..f40005ae 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -70,7 +70,27 @@ type AttributeAlias = AttributeName -- the AttributeAlias is necessary when then is otherwise a naming conflict such as with join conditions which would otherwise cause duplicate column names which SQL supports but the relational algebra does not type ColumnAliasRemapper = M.Map AttributeName (AttributeAlias, S.Set ColumnName) -insertIntoColumnAliasRemap' :: AttributeName -> AttributeAlias -> ColumnName -> ColumnAliasRemapper +insertIntoColumnAliasRemap' :: AttributeName -> AttributeAlias -> ColumnName -> ColumnAliasRemapper -> Either SQLError ColumnAliasRemapper +insertIntoColumnAliasRemap' attrName attrAlias colName remap = + case attrName `M.lookup` remap of + Nothing -> pure $ M.insert attrName (attrAlias, S.singleton colName) remap + Just (attrAlias', colNames) | attrAlias' == attrAlias -> + pure $ M.insert attrName (attrAlias, S.insert colName colNames) remap + | otherwise -> + Left (ColumnAliasResolutionError (ColumnAlias attrName)) + +-- | Used to note if columns are remapped to different attributes in order to mitigate attribute naming conflicts. +insertColumnAlias :: TableAlias -> AttributeName -> AttributeAlias -> ColumnName -> ConvertM () +insertColumnAlias tAlias attrName attrAlias colName = do + TableContext tmap <- get + case tAlias `M.lookup` tmap of + Nothing -> throwSQLE (MissingTableReferenceError tAlias) + Just (rve,attrs,remap) -> + case insertIntoColumnAliasRemap' attrName attrAlias colName remap of + Left err -> throwSQLE err + Right remap' -> do + let tmap' = M.insert tAlias (rve, attrs, remap') tmap + put (TableContext tmap') -- debugging utility function prettyTableContext :: TableContext -> String @@ -189,11 +209,8 @@ noteColumnMention mTblAlias colName mColAlias = do "mColAlias", mColAlias, p tmap) throwSQLE (DuplicateColumnAliasError newAlias)-} --duplicate column aliases are OK - --verify that the alias is not duplicated - let tmap' = M.adjust insertCol tblAlias' tmap - insertCol (rvexpr, attrs, colMap) = - (rvexpr, attrs, M.insert origAttrName (newAlias origColName colMap) - put (TableContext tmap') + --verify that the alias is not duplicated + insertColumnAlias tblAlias' origAttrName newAlias colName pure newAlias -- | Add a column alias for a column which has already been inserted into the TableContext. From bb7b26f7f92644ea2f74389d6901d302f354246c Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 5 Jan 2024 13:03:44 -0500 Subject: [PATCH 036/170] fix appveyor stack config path --- .appveyor.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.appveyor.yml b/.appveyor.yml index 62b15bc8..9d94f98f 100644 --- a/.appveyor.yml +++ b/.appveyor.yml @@ -19,7 +19,7 @@ environment: STACK_ROOT: "c:\\sr" matrix: # don't forget to also change the cache directory below - - YAML: "stack.ghc9.0.yaml" + - YAML: "stack.ghc9.2.yaml" platform: - x64 From 700af9cc7fb3b0ae08dac8b6d044fc242ec17faa Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 7 Jan 2024 00:16:12 -0500 Subject: [PATCH 037/170] update to curryer-rpc 0.3.3 for streamly 0.10.0 support websocket server test fails, why? --- cabal.project | 3 ++- project-m36.cabal | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 4a134cb0..fc74f514 100644 --- a/cabal.project +++ b/cabal.project @@ -1,8 +1,9 @@ packages: project-m36.cabal + ../curryer package * split-sections: True -- allow fast-builder to build with GHC 9.2.2 (currently pegged at 9.0.1) -allow-newer: fast-builder:base, streamly-bytestring:bytestring +allow-newer: fast-builder:base diff --git a/project-m36.cabal b/project-m36.cabal index ed37dd52..451c7878 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -35,7 +35,7 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.2, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific + Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.3, network, async, vector-instances, recursion-schemes, streamly >= 0.9.0, convertible, fast-builder, scientific if flag(haskell-scripting) Build-Depends: ghc >= 9.0 && < 9.5 CPP-Options: -DPM36_HASKELL_SCRIPTING From cdd3e2ed9dd1286894e5dfab7df1be9c7435c9fe Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 7 Jan 2024 17:35:52 -0500 Subject: [PATCH 038/170] remove special curryer-rpc from cabal.project --- cabal.project | 1 - 1 file changed, 1 deletion(-) diff --git a/cabal.project b/cabal.project index fc74f514..6bf8b77e 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,5 @@ packages: project-m36.cabal - ../curryer package * split-sections: True From 4427be0301d526e253fa2db5f785789b21850501 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 7 Jan 2024 17:53:50 -0500 Subject: [PATCH 039/170] update changelog with nonempty list fix --- Changelog.markdown | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Changelog.markdown b/Changelog.markdown index a1c92992..527a97b6 100644 --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,7 @@ +# Future + +* fixed toAtom/fromAtom for NonEmpty lists (#363) + # 2023-12-30 (v0.9.8) * fix notification serialization in transaction (#362) From 043f1483bddf3bb7b8dd572f82c396782cdb45c2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 8 Jan 2024 00:48:15 -0500 Subject: [PATCH 040/170] update nix for streamly 0.10.10 --- release.nix | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/release.nix b/release.nix index 22fb1e8a..1bde5265 100644 --- a/release.nix +++ b/release.nix @@ -15,18 +15,18 @@ let overrides = self: super: { curryer-rpc = self.callHackageDirect { pkg = "curryer-rpc"; - ver = "0.3.2"; - sha256 = "sha256-QiKsaFcIzOrtCpgVrgArnj7Hd09JVjF67huam+0aZSc="; } {}; + ver = "0.3.3"; + sha256 = "sha256-IzUOtMOfsnDG9BBvXnlywIMAUntctX0jNPZxzOQnmHo="; } {}; streamly = self.callHackageDirect { pkg = "streamly"; - ver = "0.9.0"; - sha256 = "sha256-eOxVb8qQjZDo1+S7CStqYSExOg2QHWkMY+zlOYqwZak="; } {}; + ver = "0.10.0"; + sha256 = "sha256-QkqfJ7ta+Odfv5wYL+SvOpM6ZmVTDSPxDPDhjNRU2wE="; } {}; streamly-core = self.callHackageDirect { pkg = "streamly-core"; - ver = "0.1.0"; - sha256 = "sha256-hoSV6Q2+X5a7hFnJAArqNPjcMaCVyX9Vz4FcxeJ+jgI="; } {}; + ver = "0.2.0"; + sha256 = "sha256-fMo5dz/AY0CUZaP1lhXqjfsuGVO4GtAW3/q9W9N6D3Q="; } {}; lockfree-queue = self.callHackageDirect { pkg = "lockfree-queue"; From 19669db26a9c50cff002f9a083a4462d126be98d Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 8 Jan 2024 01:07:04 -0500 Subject: [PATCH 041/170] update nix with streamly-bytestring 0.2.1 --- release.nix | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/release.nix b/release.nix index 1bde5265..a3baca49 100644 --- a/release.nix +++ b/release.nix @@ -27,6 +27,10 @@ let pkg = "streamly-core"; ver = "0.2.0"; sha256 = "sha256-fMo5dz/AY0CUZaP1lhXqjfsuGVO4GtAW3/q9W9N6D3Q="; } {}; + streamly-bytestring = self.callHackageDirect { + pkg = "streamly-bytestring"; + ver = "0.2.1"; + sha256 = "sha256-EcH6qq4nRjea3xQ66Zlqgjjg7lF/grkKJI0+tTO4B84="; } {}; lockfree-queue = self.callHackageDirect { pkg = "lockfree-queue"; From c61b121336044d31ab57f3c0242d8b7844fd7c2d Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 8 Jan 2024 10:54:55 -0500 Subject: [PATCH 042/170] wip compilation checkpoint --- src/bin/SQL/Interpreter/Convert.hs | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index f40005ae..8271f042 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -195,12 +195,12 @@ noteColumnMention mTblAlias colName mColAlias = do -- insert into the column alias map let newAlias = case mColAlias of Nothing -> case colName of - ColumnName [c] -> ColumnAlias c - ColumnName [t,c] -> ColumnAlias (t <> "." <> c) - Just al -> al + ColumnName [c] -> c + ColumnName [t,c] -> t <> "." <> c + Just (ColumnAlias al) -> al origAttrName = case colName of - [c] -> c - [_,c] -> c + ColumnName [c] -> c + ColumnName [_,c] -> c {- when (newAlias `elem` allColumnAliases tcontext) $ do traceShowM ("gonk error", @@ -211,8 +211,9 @@ p tmap) throwSQLE (DuplicateColumnAliasError newAlias)-} --duplicate column aliases are OK --verify that the alias is not duplicated insertColumnAlias tblAlias' origAttrName newAlias colName - pure newAlias + pure (ColumnAlias newAlias) +{- -- | Add a column alias for a column which has already been inserted into the TableContext. addColumnAlias' :: TableContext -> TableAlias -> ColumnAlias -> AttributeName -> Either SQLError TableContext addColumnAlias' (TableContext tctx) tAlias colAlias@(ColumnAlias colText) attr = do @@ -221,6 +222,7 @@ addColumnAlias' (TableContext tctx) tAlias colAlias@(ColumnAlias colText) attr = Just (rvexpr, attrs, colMap) -> --check that the attribute is present in attributes, then plop it into the colMap and return the updated TableContext if attr `A.isAttributeNameContained` attrs then do + insertColumnAlias let newColMap = M.insert colAlias attr colMap newTContext = M.insert tAlias (rvexpr, attrs, newColMap) tctx pure (TableContext newTContext) @@ -239,8 +241,8 @@ allColumnAliases (TableContext tmap) = foldl' folder [] tmap where folder acc (_,_,colmap) = M.keys colmap <> acc - -lookupTable :: TableAlias -> ConvertM (RelationalExpr, Attributes, ColumnAliasMap) +-} +lookupTable :: TableAlias -> ConvertM (RelationalExpr, Attributes, ColumnAliasRemapper) lookupTable ta = do (TableContext map') <- get case M.lookup ta map' of @@ -313,8 +315,8 @@ attributeNameForColumnName' colName tcontext@(TableContext tmap) = do ColumnName [tname,attr] -> pure $ ColumnAlias (tname <> "." <> attr) ColumnName{} -> Left $ ColumnResolutionError colName traceShowM ("attributeNameForColumnName' colAlias", colAliases, colAlias) - case M.lookup colAlias colAliases of - Just res -> pure res -- we found it, so it's valid + case M.lookup colAttr colAliases of + Just (res,_) -> pure res -- we found it, so it's valid Nothing -> -- look in rvattrs, so we don't need the table alias prefix. The lack of an entry in the column alias map indicates that the column was not renamed in the join condition. if colAttr `A.isAttributeNameContained` rvattrs then @@ -700,11 +702,13 @@ joinTableRef typeF rvA (c,tref) = do -- insert into columnAliasMap let new_name = T.concat [prefix, ".", old_name] -- traceShowM ("prefixOneAttr", tAlias, old_name, new_name) - addColumnAlias tAlias (ColumnAlias new_name) old_name + insertColumnAlias tAlias old_name new_name (ColumnName [new_name]) +-- addColumnAlias tAlias (ColumnAlias new_name) old_name pure (old_name, new_name) renameOneAttr x expr old_name = do -- traceShowM ("renameOneAttr", old_name, new_name) - addColumnAlias (TableAlias prefix) (ColumnAlias new_name) old_name + insertColumnAlias (TableAlias prefix) old_name new_name (ColumnName [new_name]) +-- addColumnAlias (TableAlias prefix) (ColumnAlias new_name) old_name pure (old_name, new_name) where new_name = T.concat [prefix, ".", old_name] From 4b0200a47fffd9691c7a9d604db4cbe378b90d27 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 8 Jan 2024 13:17:07 -0500 Subject: [PATCH 043/170] squelch hlint warning about lists in Atomable --- src/lib/ProjectM36/Atomable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/ProjectM36/Atomable.hs b/src/lib/ProjectM36/Atomable.hs index df696e16..4be5c421 100644 --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -158,7 +158,7 @@ instance Atomable a => Atomable [a] where instance Atomable a => Atomable (NE.NonEmpty a) where toAtom (x NE.:| []) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) [toAtom x] - toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) (toAtom x : toAtom xs : []) + toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) [toAtom x, toAtom xs] fromAtom (ConstructedAtom "NECons" _ [x]) = fromAtom x NE.:| [] fromAtom (ConstructedAtom "NECons" _ [x,y] ) = fromAtom x NE.:| fromAtom y fromAtom x = error "improper fromAtom (NonEmptyList a)" From ded71442f8ca2689e65e21014bdb6dff63e776c7 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 9 Jan 2024 16:31:15 -0500 Subject: [PATCH 044/170] add pretty printer for DataFrameExpr --- src/bin/TutorialD/Printer.hs | 26 ++++++++++++++++++++++++++ test/SQL/InterpreterTest.hs | 4 ++++ 2 files changed, 30 insertions(+) diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index d5f6d6aa..6e55cceb 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -6,6 +6,7 @@ module TutorialD.Printer where import ProjectM36.Base import ProjectM36.Attribute as A hiding (null) +import ProjectM36.DataFrame import Prettyprinter import qualified Data.Set as S hiding (fromList) import qualified Data.Vector as V @@ -164,6 +165,31 @@ instance Pretty RestrictionPredicateExpr where instance Pretty WithNameExpr where pretty (WithNameExpr name _) = pretty name +instance Pretty DataFrameExpr where + pretty df = + ":showdataframe" <+> + pretty (convertExpr df) <+> + if null (orderExprs df) then + mempty + else + "orderby" <+> + prettyBracesList (orderExprs df) + <+> prettyOffset (offset df) + <+> prettyLimit (limit df) + where + prettyOffset Nothing = mempty + prettyOffset (Just offset') = "offset" <+> pretty (show offset') + prettyLimit Nothing = mempty + prettyLimit (Just limit') = "limit" <+> pretty (show limit') + +instance Pretty AttributeOrderExpr where + pretty (AttributeOrderExpr attrName order) = + pretty attrName <+> pretty order + +instance Pretty Order where + pretty AscendingOrder = "ascending" + pretty DescendingOrder = "descending" + bracesList :: [Doc ann] -> Doc ann bracesList = group . encloseSep (flatAlt "{ " "{") (flatAlt " }" "}") ", " diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index e4dc4f70..f0ba609c 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -3,6 +3,8 @@ import SQL.Interpreter.Select import SQL.Interpreter.Convert --import TutorialD.Interpreter.RelationalExpr import TutorialD.Interpreter.RODatabaseContextOperator +import TutorialD.Printer +import Prettyprinter import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph import ProjectM36.DateExamples @@ -154,6 +156,8 @@ testSelect = TestCase $ do pure x --print ("selectAsRelExpr"::String, selectAsRelExpr) + print ("expected: ", pretty tutdAsDFExpr) + print ("actual: ", pretty selectAsDFExpr) assertEqual (T.unpack sql) tutdAsDFExpr selectAsDFExpr --check that the expression can actually be executed eEvald <- executeDataFrameExpr sess conn tutdAsDFExpr From ae5bac242e0ec8a89841f4791e3580234a8bed8b Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 9 Jan 2024 16:31:25 -0500 Subject: [PATCH 045/170] fic some warnings --- src/bin/SQL/Interpreter/Convert.hs | 15 +++++---------- src/lib/ProjectM36/Atomable.hs | 2 +- src/lib/ProjectM36/StaticOptimizer.hs | 6 ++++-- 3 files changed, 10 insertions(+), 13 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 8271f042..42850f0c 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -3,28 +3,24 @@ module SQL.Interpreter.Convert where import ProjectM36.Base import ProjectM36.Error -import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), AttributeOrder(..),Order(..), usesDataFrameFeatures) +import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A import qualified ProjectM36.Attribute as A -import qualified ProjectM36.WithNameExpr as W import SQL.Interpreter.Select -import Data.Kind (Type) import qualified Data.Text as T import qualified ProjectM36.WithNameExpr as With import ProjectM36.Relation -import Control.Monad (foldM, liftM) +import Control.Monad (foldM) import qualified Data.Set as S import qualified Data.Map as M -import Data.List (foldl', intercalate, find) +import Data.List (intercalate, find) import qualified Data.Functor.Foldable as Fold import qualified Data.List.NonEmpty as NE import Control.Monad (when) import ProjectM36.DataTypes.Maybe -import ProjectM36.StaticOptimizer import Control.Monad (void) -import Data.Maybe (fromMaybe) import Control.Monad.Trans.State (StateT, get, put, runStateT, evalStateT) -import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT, catchE) +import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Trans.Class (lift) @@ -96,7 +92,7 @@ insertColumnAlias tAlias attrName attrAlias colName = do prettyTableContext :: TableContext -> String prettyTableContext (TableContext tMap) = "TableContext {\n" <> concatMap prettyKV (M.toList tMap) <> "}" where - prettyKV (TableAlias k,(rvexpr, attrs, aliasMap)) = + prettyKV (TableAlias k, (_rvexpr, _attrs, aliasMap)) = T.unpack k <> "::\n" <> prettyColumnAliasRemapper aliasMap @@ -123,7 +119,6 @@ tableAliasesAsWithNameAssocs = do notSelfRef _ = True -- mapper :: (TableAlias, (RelationalExpr, Attributes)) -> ConvertM (WithNameExpr, RelationalExpr) mapper (TableAlias nam, (rvExpr, _, _)) = pure (WithNameExpr nam (), rvExpr) - mapper (qn, _) = throwSQLE (NotSupportedError ("schema qualified table names: " <> T.pack (show qn))) throwSQLE :: SQLError -> ConvertM a throwSQLE = lift . throwE diff --git a/src/lib/ProjectM36/Atomable.hs b/src/lib/ProjectM36/Atomable.hs index df696e16..aedd2ad8 100644 --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -161,7 +161,7 @@ instance Atomable a => Atomable (NE.NonEmpty a) where toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) (toAtom x : toAtom xs : []) fromAtom (ConstructedAtom "NECons" _ [x]) = fromAtom x NE.:| [] fromAtom (ConstructedAtom "NECons" _ [x,y] ) = fromAtom x NE.:| fromAtom y - fromAtom x = error "improper fromAtom (NonEmptyList a)" + fromAtom _x = error "improper fromAtom (NonEmptyList a)" toAtomType _ = ConstructedAtomType "NonEmptyList" (M.singleton "a" (toAtomType (Proxy :: Proxy a))) toAddTypeExpr _ = NoOperation diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index ed2c039c..60d75fec 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -20,7 +20,7 @@ import Data.Functor.Identity import qualified Data.Map as M import qualified Data.Set as S import Data.Functor.Foldable as Fold -import Debug.Trace +--import Debug.Trace -- the static optimizer performs optimizations which need not take any specific-relation statistics into account @@ -589,15 +589,17 @@ applyRedundantRenameCleanup expr = Fold.cata folder expr else Rename (S.filter (\(a,b) -> a /= b) renameSet) e folder e = Fold.embed e + -- if the destination name in the rename is unused, we can remove it- does not detect errors if an a Rename is missing -- Project ["x"] (Rename [("y","z"),("w","x")] (RelationVariable "rv" ())) == Project ["x"] (Rename [("w","x")] (RelationVariable "rv" ())) +{- applyUnusedRenameCleanup :: Show a => RelationalExprBase a -> RelationalExprBase a applyUnusedRenameCleanup expr = Fold.para folder expr where folder :: Show a => RelationalExprBaseF a (RelationalExprBase a, RelationalExprBase a) -> RelationalExprBase a folder (RenameF renameSet (expr', acc)) = traceShow ("para", expr', acc) (Rename renameSet expr') folder e = traceShow ("para2", Fold.embed $ fst <$> e) $ Fold.embed $ fst <$> e - +-} -- no optimizations available optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr optimizeDatabaseContextIOExpr = pure From 3dfa461b5884caeab75b6aa456c986fced4b6985 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 11 Jan 2024 22:47:21 -0500 Subject: [PATCH 046/170] fix attribute-related pretty printer for tutd --- src/bin/TutorialD/Printer.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index 6e55cceb..2680d717 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -35,7 +35,7 @@ instance Pretty Atom where pretty (ConstructedAtom n _ as) = pretty n <+> prettyList as instance Pretty AtomExpr where - pretty (AttributeAtomExpr attrName) = pretty attrName + pretty (AttributeAtomExpr attrName) = pretty ("@" <> attrName) pretty (NakedAtomExpr atom) = pretty atom pretty (FunctionAtomExpr atomFuncName' atomExprs _) = pretty atomFuncName' <> prettyAtomExprsAsArguments atomExprs pretty (RelationAtomExpr relExpr) = pretty relExpr @@ -160,7 +160,10 @@ instance Pretty RestrictionPredicateExpr where pretty (NotPredicate a) = "not" <+> pretty a pretty (RelationalExprPredicate relExpr) = pretty relExpr pretty (AtomExprPredicate atomExpr) = pretty atomExpr - pretty (AttributeEqualityPredicate attrName atomExpr) = pretty attrName <> "=" <> pretty atomExpr + pretty (AttributeEqualityPredicate attrName atomExpr) = prettyAttributeName attrName <> "=" <> pretty atomExpr + +prettyAttributeName :: AttributeName -> Doc a +prettyAttributeName attrName = pretty $ "`" <> attrName <> "`" instance Pretty WithNameExpr where pretty (WithNameExpr name _) = pretty name From cd375e46f9c12dd19b62e93e9b290b725fed20d6 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 11 Jan 2024 22:47:30 -0500 Subject: [PATCH 047/170] fix more warnings --- src/bin/SQL/Interpreter/Convert.hs | 70 +++++++++++++++--------------- 1 file changed, 36 insertions(+), 34 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 42850f0c..546d010b 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -26,6 +26,13 @@ import Control.Monad.Trans.Class (lift) import Debug.Trace +{- +TODO +* remove commented out code +* remove unused functions from failed experiments +* remove traceShow* +-} + data SQLError = NotSupportedError T.Text | TypeMismatchError AtomType AtomType | NoSuchSQLFunctionError FuncName | @@ -128,17 +135,15 @@ withSubSelect :: ConvertM a -> ConvertM (a, TableContext) withSubSelect m = do state@(TableContext orig) <- get ret <- m - state'@(TableContext postSub) <- get + (TableContext postSub) <- get put state -- diff the state to get just the items that were added - traceShowM ("diff orig", M.keys orig) - traceShowM ("diff postSub", M.keys postSub) - traceShowM ("diff1", M.difference postSub orig) + traceShowM ("diff orig"::String, M.keys orig) + traceShowM ("diff postSub"::String, M.keys postSub) + traceShowM ("diff1"::String, M.difference postSub orig) let diff = M.differenceWith tctxDiff postSub orig tctxDiff (rexprA, attrsA, colAliasMapA) (_, _, colAliasMapB) = Just (rexprA, attrsA, M.difference colAliasMapB colAliasMapA) - tctxDiff (rexprA, attrsA, alMap) (_, _,_) = - Just (rexprA, attrsA, alMap) pure (ret, TableContext diff) -- if we find a column naming conflict, generate a non-conflicting name for insertion into the column alias map @@ -147,26 +152,26 @@ generateColumnAlias (TableAlias tAlias) attrName = do tctx <- get let potentialNames = map ColumnName ([[attrName], [tAlias <> "." <> attrName]] <> - map (\x -> [tAlias <> "." <> attrName <> T.pack (show x)]) [1..]) + map (\x -> [tAlias <> "." <> attrName <> T.pack (show x)]) [1::Int ..]) nameIsAvailable nam = case findOneColumn' nam tctx of Left ColumnResolutionError{} -> --no match, so we can use this name True _ -> False --some conflict, so loop firstAvailableName = find nameIsAvailable potentialNames - traceShowM ("generateColumnAlias scan", tAlias, attrName, firstAvailableName) + traceShowM ("generateColumnAlias scan"::String, tAlias, attrName, firstAvailableName) case firstAvailableName of Just (ColumnName [nam]) -> pure (ColumnAlias nam) _ -> throwSQLE (ColumnResolutionError (ColumnName [attrName])) -- | Insert another table into the TableContext. Returns an alias map of any columns which could conflict with column names already present in the TableContext so that they can be optionally renamed. insertTable :: TableAlias -> RelationalExpr -> Attributes -> ConvertM ColumnAliasMap -insertTable tAlias@(TableAlias tAlias') expr rtype = do +insertTable tAlias expr rtype = do (TableContext map') <- get case M.lookup tAlias map' of Nothing -> do put $ TableContext $ M.insert tAlias (expr, rtype, mempty) map' - traceShowM ("insertTable", tAlias) + traceShowM ("insertTable"::String, tAlias) traceStateM pure mempty Just _ -> throwSQLE (DuplicateTableReferenceError tAlias) @@ -174,16 +179,15 @@ insertTable tAlias@(TableAlias tAlias') expr rtype = do -- | When a column is mentioned, it may need to be aliased. The table name must already be in the table context so that we can identify that the attribute exists. Without a table name, we must look for a uniquely named column amongst all tables. Thus, we pre-emptively eliminate duplicate column names. noteColumnMention :: Maybe TableAlias -> ColumnName -> Maybe ColumnAlias -> ConvertM ColumnAlias noteColumnMention mTblAlias colName mColAlias = do - tcontext@(TableContext tmap) <- get -- find the relevant table for the key to the right table - traceShowM ("noteColumnMention", colName) + traceShowM ("noteColumnMention"::String, colName) tblAlias' <- case mTblAlias of Just tblAlias -> do void $ lookupTable tblAlias pure tblAlias Nothing ->do -- scan column names for match- if there are multiple matches, return a column ambiguity error - traceShowM ("insertColumn", colName) + traceShowM ("insertColumn"::String, colName) ret <- findOneColumn colName -- traceShowM ("insertColumn2", colName) pure ret @@ -267,7 +271,7 @@ findColumn' targetCol (TableContext tMap) = do -- traceShowM ("findColumn'", targetCol, tMap) M.foldrWithKey folder [] tMap where - folder tAlias@(TableAlias tat) (rvExpr, rtype, _) acc = + folder tAlias@(TableAlias tat) (_rvExpr, rtype, _) acc = case targetCol of ColumnName [colName'] -> if S.member colName' (A.attributeNameSet rtype) then @@ -281,9 +285,6 @@ findColumn' targetCol (TableContext tMap) = do acc _ -> acc ---findColumnAlias' :: ColumnAlias - - findOneColumn :: ColumnName -> ConvertM TableAlias findOneColumn targetCol = do tcontext <- get @@ -295,21 +296,21 @@ findOneColumn' :: ColumnName -> TableContext -> Either SQLError TableAlias findOneColumn' targetCol tcontext = do case findColumn' targetCol tcontext of [] -> do - traceShow ("findOneColumn'", targetCol) $ Left (ColumnResolutionError targetCol) + traceShow ("findOneColumn'"::String, targetCol) $ Left (ColumnResolutionError targetCol) [match] -> pure match _matches -> Left (AmbiguousColumnResolutionError targetCol) -- | Search the TableContext for a column alias remapping for the given column name. attributeNameForColumnName' :: ColumnName -> TableContext -> Either SQLError AttributeName attributeNameForColumnName' colName tcontext@(TableContext tmap) = do - tKey@(TableAlias tAlias) <- findOneColumn' colName tcontext + tKey <- findOneColumn' colName tcontext let (_, rvattrs, colAliases) = tmap M.! tKey --strip table prefix, if necessary colAlias@(ColumnAlias colAttr) <- case colName of ColumnName [attr] -> pure $ ColumnAlias attr ColumnName [tname,attr] -> pure $ ColumnAlias (tname <> "." <> attr) ColumnName{} -> Left $ ColumnResolutionError colName - traceShowM ("attributeNameForColumnName' colAlias", colAliases, colAlias) + traceShowM ("attributeNameForColumnName' colAlias"::String, colAliases, colAlias) case M.lookup colAttr colAliases of Just (res,_) -> pure res -- we found it, so it's valid Nothing -> @@ -322,7 +323,7 @@ attributeNameForColumnName' colName tcontext@(TableContext tmap) = do ColumnName [_, col] | col `A.isAttributeNameContained` rvattrs -> -- the column has not been aliased, so we presume it can be use the column name directly pure col - _ -> traceShow ("attrNameForColName") $ Left $ ColumnResolutionError colName + _ -> traceShow ("attrNameForColName"::String) $ Left $ ColumnResolutionError colName attributeNameForColumnName :: ColumnName -> ConvertM AttributeName attributeNameForColumnName colName = do @@ -331,7 +332,7 @@ attributeNameForColumnName colName = do Left err -> throwSQLE err Right al -> do traceStateM - traceShowM ("attributeNameForColumnName", colName, "->", al) + traceShowM ("attributeNameForColumnName"::String, colName, "->"::String, al) pure al @@ -381,7 +382,7 @@ convertSelect typeF sel = do convertWithClause typeF wClause -- extract all mentioned tables into the table alias map for let typeF' = appendWithsToTypeF typeF wExprs - (dfExpr, colRemap) <- case tableExpr sel of + (dfExpr, _colRemap) <- case tableExpr sel of Nothing -> pure (baseDFExpr, mempty) Just tExpr -> convertTableExpr typeF' tExpr -- traceShowM ("table aliases", tAliasMap) @@ -396,7 +397,6 @@ convertSelect typeF sel = do _ -> With withAssocs finalRelExpr = explicitWithF (withF (projF (convertExpr dfExpr))) -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes - s <- get traceStateM -- apply rename reduction- this could be applied by the static query optimizer, but we do it here to simplify the tests so that they aren't polluted with redundant renames pure (dfExpr { convertExpr = finalRelExpr }) @@ -425,7 +425,7 @@ convertSubSelect typeF sel = do Nothing -> pure (baseDFExpr, mempty) Just tExpr -> convertTableExpr typeF' tExpr when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") - traceShowM ("convertSubSelect", colMap) + traceShowM ("convertSubSelect"::String, colMap) let explicitWithF = if null wExprs then id else With wExprs -- convert projection using table alias map to resolve column names projF <- convertProjection typeF' (projectionClause sel) -- the projection can only project on attributes from the subselect table expression @@ -436,7 +436,7 @@ convertSubSelect typeF sel = do _ -> With withAssocs -- add disambiguation renaming pure (explicitWithF (withF (projF (convertExpr dfExpr)))) - traceShowM ("diff", aliasDiff) -- alias is not correct- the col alias map is empty for subquery + traceShowM ("diff"::String, aliasDiff) -- alias is not correct- the col alias map is empty for subquery pure ret convertSelectItem :: TypeForRelExprF -> SelectItemsConvertTask -> (Int,SelectItem) -> ConvertM SelectItemsConvertTask @@ -449,7 +449,7 @@ convertSelectItem typeF acc (c,selItem) = (Identifier qpn@(ColumnProjectionName [ProjectionName _, Asterisk]), Nothing) -> pure $ acc { taskProjections = S.insert qpn (taskProjections acc) } -- select a from x - (Identifier qpn@(ColumnProjectionName [ProjectionName col]), Nothing) -> do + (Identifier qpn@(ColumnProjectionName [ProjectionName _col]), Nothing) -> do --look up unaliased column name _ <- colinfo qpn pure $ acc { taskProjections = S.insert qpn (taskProjections acc) @@ -466,7 +466,7 @@ convertSelectItem typeF acc (c,selItem) = -- other exprs (scalarExpr, mAlias) -> do let attrName' (Just (ColumnAlias nam)) _ = nam - attrName' Nothing c = "attr_" <> T.pack (show c) + attrName' Nothing c' = "attr_" <> T.pack (show c') atomExpr <- convertProjectionScalarExpr typeF scalarExpr let newAttrName = attrName' mAlias c -- we need to apply the projections after the extension! @@ -483,8 +483,8 @@ convertProjection typeF selItems = do let emptyTask = SelectItemsConvertTask { taskProjections = S.empty, taskRenames = mempty, taskExtenders = mempty } - attrName' (Just (ColumnAlias nam)) _ = nam - attrName' Nothing c = "attr_" <> T.pack (show c) +-- attrName' (Just (ColumnAlias nam)) _ = nam +-- attrName' Nothing c = "attr_" <> T.pack (show c) task <- foldM (convertSelectItem typeF) emptyTask (zip [1::Int ..] selItems) --apply projections fProjection <- if S.null (taskProjections task) then @@ -697,9 +697,10 @@ joinTableRef typeF rvA (c,tref) = do -- insert into columnAliasMap let new_name = T.concat [prefix, ".", old_name] -- traceShowM ("prefixOneAttr", tAlias, old_name, new_name) + (ColumnAlias alias) <- noteColumnMention (Just tAlias) (ColumnName [old_name]) (Just (ColumnAlias new_name)) insertColumnAlias tAlias old_name new_name (ColumnName [new_name]) -- addColumnAlias tAlias (ColumnAlias new_name) old_name - pure (old_name, new_name) + pure (old_name, alias) renameOneAttr x expr old_name = do -- traceShowM ("renameOneAttr", old_name, new_name) insertColumnAlias (TableAlias prefix) old_name new_name (ColumnName [new_name]) @@ -785,7 +786,7 @@ joinTableRef typeF rvA (c,tref) = do firstAvailableName (c + 1) allAttrs' else new_name - joinName = firstAvailableName 1 allAttrs + joinName = firstAvailableName (1::Int) allAttrs extender = AttributeExtendTupleExpr joinName joinRe joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) @@ -857,6 +858,7 @@ needsToRenameAllAttributes (RestrictionExpr sexpr) = case sexpr' of DoubleLiteral{} -> False StringLiteral{} -> False + IntegerLiteral{} -> False NullLiteral{} -> False Identifier{} -> False BinaryOperator e1 _ e2 -> rec' e1 || rec' e2 @@ -866,8 +868,8 @@ needsToRenameAllAttributes (RestrictionExpr sexpr) = FunctionApplication _ e1 -> rec' e1 CaseExpr cases else' -> or (map (\(whens, then') -> or (map rec' whens) || rec' then') cases) - qc@QuantifiedComparison{} -> True - InExpr _ sexpr _ -> rec' sexpr + QuantifiedComparison{} -> True + InExpr _ sexpr' _ -> rec' sexpr' BooleanOperatorExpr e1 _ e2 -> rec' e1 || rec' e2 ExistsExpr{} -> True From d450f9c6001b5504c0c684b524f7924e4565e3bd Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 12 Jan 2024 22:15:08 -0500 Subject: [PATCH 048/170] revert to streamly 0.9.0 to skip potentially buggy streamly 0.10.0 resulting in TCP stream corruption --- project-m36.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project-m36.cabal b/project-m36.cabal index 451c7878..a7c85457 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -35,7 +35,7 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.3, network, async, vector-instances, recursion-schemes, streamly >= 0.9.0, convertible, fast-builder, scientific + Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.4, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific if flag(haskell-scripting) Build-Depends: ghc >= 9.0 && < 9.5 CPP-Options: -DPM36_HASKELL_SCRIPTING From cc66a7588d0d7c4a8d3a9a0cb360700e395c8d44 Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 12 Jan 2024 23:49:18 -0500 Subject: [PATCH 049/170] update version to 0.9.9 after reverting to streamly 0.9.0 --- Changelog.markdown | 3 ++- project-m36.cabal | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Changelog.markdown b/Changelog.markdown index 527a97b6..aaca84ee 100644 --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,5 +1,6 @@ -# Future +# 2024-01-12 (v0.9.9) +* revert to using streamly 0.9.0 due to over-the-wire corruption bug in 0.10.0 * fixed toAtom/fromAtom for NonEmpty lists (#363) # 2023-12-30 (v0.9.8) diff --git a/project-m36.cabal b/project-m36.cabal index a7c85457..e3a36998 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 0.9.8 +Version: 0.9.9 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple From bb94fab75fb2c409d3e7d487cdc640d52635df34 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 13 Jan 2024 00:58:35 -0500 Subject: [PATCH 050/170] fix docker build with downgrade to streamly 0.9.0 and curryer-rpc 0.3.5 --- project-m36.cabal | 2 +- release.nix | 13 +++++++------ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index e3a36998..731bc3bf 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -35,7 +35,7 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.4, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific + Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.5, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific if flag(haskell-scripting) Build-Depends: ghc >= 9.0 && < 9.5 CPP-Options: -DPM36_HASKELL_SCRIPTING diff --git a/release.nix b/release.nix index a3baca49..f09ea202 100644 --- a/release.nix +++ b/release.nix @@ -15,18 +15,19 @@ let overrides = self: super: { curryer-rpc = self.callHackageDirect { pkg = "curryer-rpc"; - ver = "0.3.3"; - sha256 = "sha256-IzUOtMOfsnDG9BBvXnlywIMAUntctX0jNPZxzOQnmHo="; } {}; + ver = "0.3.5"; + sha256 = "sha256-7mEJOBKzA2rTnLxZme8E6zFv0VkiXBo5L/jUJSNPaNE="; } {}; streamly = self.callHackageDirect { pkg = "streamly"; - ver = "0.10.0"; - sha256 = "sha256-QkqfJ7ta+Odfv5wYL+SvOpM6ZmVTDSPxDPDhjNRU2wE="; } {}; + ver = "0.9.0"; + sha256 = "sha256-eOxVb8qQjZDo1+S7CStqYSExOg2QHWkMY+zlOYqwZak="; } {}; streamly-core = self.callHackageDirect { pkg = "streamly-core"; - ver = "0.2.0"; - sha256 = "sha256-fMo5dz/AY0CUZaP1lhXqjfsuGVO4GtAW3/q9W9N6D3Q="; } {}; + ver = "0.1.0"; + sha256 = "sha256-hoSV6Q2+X5a7hFnJAArqNPjcMaCVyX9Vz4FcxeJ+jgI="; } {}; + streamly-bytestring = self.callHackageDirect { pkg = "streamly-bytestring"; ver = "0.2.1"; From 4dd0d84aecd32d14db8699da1c1a15fcd82cd8f4 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 15 Jan 2024 16:19:52 -0500 Subject: [PATCH 051/170] be more careful when trimming the transaction graph- make sure to include transactions referenced by the truly relevant transactions resolves #364 --- project-m36.cabal | 3 +- src/lib/ProjectM36/Atomable.hs | 2 +- src/lib/ProjectM36/Base.hs | 8 +- src/lib/ProjectM36/Error.hs | 3 +- .../ProjectM36/ReferencedTransactionIds.hs | 117 ++++++++++++++++++ src/lib/ProjectM36/TransactionGraph.hs | 21 +++- src/lib/ProjectM36/TransactionGraph/Merge.hs | 8 +- test/TransactionGraph/Merge.hs | 4 +- 8 files changed, 148 insertions(+), 18 deletions(-) create mode 100644 src/lib/ProjectM36/ReferencedTransactionIds.hs diff --git a/project-m36.cabal b/project-m36.cabal index e3a36998..11b7b332 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -134,7 +134,8 @@ Library ProjectM36.Trace, ProjectM36.HashSecurely, ProjectM36.DDLType, - ProjectM36.RegisteredQuery + ProjectM36.RegisteredQuery, + ProjectM36.ReferencedTransactionIds GHC-Options: -Wall -rdynamic if os(windows) Build-Depends: Win32 >= 2.12 diff --git a/src/lib/ProjectM36/Atomable.hs b/src/lib/ProjectM36/Atomable.hs index 4be5c421..78f84404 100644 --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -161,7 +161,7 @@ instance Atomable a => Atomable (NE.NonEmpty a) where toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) [toAtom x, toAtom xs] fromAtom (ConstructedAtom "NECons" _ [x]) = fromAtom x NE.:| [] fromAtom (ConstructedAtom "NECons" _ [x,y] ) = fromAtom x NE.:| fromAtom y - fromAtom x = error "improper fromAtom (NonEmptyList a)" + fromAtom _x = error "improper fromAtom (NonEmptyList a)" toAtomType _ = ConstructedAtomType "NonEmptyList" (M.singleton "a" (toAtomType (Proxy :: Proxy a))) toAddTypeExpr _ = NoOperation diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 8717b78b..21a66082 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -454,6 +454,9 @@ transactionHeadsForGraph (TransactionGraph hs _) = hs transactionsForGraph :: TransactionGraph -> S.Set Transaction transactionsForGraph (TransactionGraph _ ts) = ts +transactionIdsForGraph :: TransactionGraph -> S.Set TransactionId +transactionIdsForGraph = S.map transactionId . transactionsForGraph + -- | Every transaction has context-specific information attached to it. -- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch). data TransactionInfo = TransactionInfo { @@ -463,11 +466,6 @@ data TransactionInfo = TransactionInfo { } deriving (Show, Generic) type TransactionParents = NE.NonEmpty TransactionId -{- -data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime | -- 1 parent + n children - MergeTransactionInfo TransactionId TransactionId TransactionDiffs UTCTime -- 2 parents, n children - deriving (Show, Generic) --} -- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction. type TransactionId = UUID diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs index a5d2c401..16d85dfe 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -131,7 +131,8 @@ data MergeError = SelectedHeadMismatchMergeError | InvalidMergeStrategyError MergeStrategy | -- this is an internal coding error DisconnectedTransactionNotAMergeHeadError TransactionId | StrategyViolatesComponentMergeError | --failed merge in inc deps, relvars, etc. - StrategyViolatesRelationVariableMergeError | + StrategyViolatesRelationVariableMergeError RelationalError | + StrategyWithoutPreferredBranchResolutionMergeError | StrategyViolatesTypeConstructorMergeError | StrategyViolatesRegisteredQueryMergeError [RegisteredQueryName] deriving (Show, Eq, Generic, Typeable) diff --git a/src/lib/ProjectM36/ReferencedTransactionIds.hs b/src/lib/ProjectM36/ReferencedTransactionIds.hs new file mode 100644 index 00000000..56033428 --- /dev/null +++ b/src/lib/ProjectM36/ReferencedTransactionIds.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleInstances #-} +module ProjectM36.ReferencedTransactionIds where +import ProjectM36.Base +import qualified Data.Map as M +import qualified Data.Set as S + +type TransactionIds = S.Set TransactionId + +-- return all transactionIds referenced recursively- can be used to create subgraph of transaction dependencies +class ReferencedTransactionIds a where + referencedTransactionIds :: a -> TransactionIds + +instance ReferencedTransactionIds a => ReferencedTransactionIds (RelationalExprBase a) where + referencedTransactionIds x = case x of + MakeRelationFromExprs (Just attrExprs) tupleExprs -> + S.unions (referencedTransactionIds tupleExprs : map referencedTransactionIds attrExprs) + MakeRelationFromExprs Nothing tupleExprs -> + referencedTransactionIds tupleExprs + MakeStaticRelation{} -> S.empty + ExistingRelation{} -> S.empty + RelationVariable _ marker -> referencedTransactionIds marker + Project attrNames expr -> S.union (referencedTransactionIds attrNames) (referencedTransactionIds expr) + Union exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + Join exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + Rename _ _ expr -> referencedTransactionIds expr + Difference exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + Group attrNames _ expr -> S.union (referencedTransactionIds attrNames) (referencedTransactionIds expr) + Ungroup _ expr -> referencedTransactionIds expr + Restrict pred' expr -> S.union (referencedTransactionIds pred') (referencedTransactionIds expr) + Equals exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + NotEquals exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + Extend extendTupleExpr expr -> S.union (referencedTransactionIds extendTupleExpr) (referencedTransactionIds expr) + With assocs expr -> S.unions (referencedTransactionIds expr : map tAssocs assocs) + where + tAssocs (withNameExpr, rExpr) = S.union (referencedTransactionIds withNameExpr) (referencedTransactionIds rExpr) + +instance ReferencedTransactionIds a => ReferencedTransactionIds (AttributeExprBase a) where + referencedTransactionIds NakedAttributeExpr{} = S.empty + referencedTransactionIds (AttributeAndTypeNameExpr _ _ marker) = referencedTransactionIds marker + +instance ReferencedTransactionIds a => ReferencedTransactionIds (TupleExprBase a) where + referencedTransactionIds (TupleExpr tMap) = + S.unions (referencedTransactionIds <$> M.elems tMap) + +instance ReferencedTransactionIds a => ReferencedTransactionIds (TupleExprsBase a) where + referencedTransactionIds (TupleExprs marker tupleExprs) = + S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> tupleExprs)) + +instance ReferencedTransactionIds GraphRefTransactionMarker where + referencedTransactionIds (TransactionMarker tid) = S.singleton tid + referencedTransactionIds UncommittedContextMarker = S.empty -- we have other methods to determine if there is an uncommitted transaction marker in the expr + +instance ReferencedTransactionIds a => ReferencedTransactionIds (AttributeNamesBase a) where + referencedTransactionIds names = + case names of + AttributeNames{} -> S.empty + InvertedAttributeNames{} -> S.empty + UnionAttributeNames exprA exprB -> + S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + IntersectAttributeNames exprA exprB -> + S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + RelationalExprAttributeNames rExpr -> + referencedTransactionIds rExpr + +instance ReferencedTransactionIds a => ReferencedTransactionIds (RestrictionPredicateExprBase a) where + referencedTransactionIds expr = + case expr of + TruePredicate -> mempty + AndPredicate exprA exprB -> + S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + OrPredicate exprA exprB -> + S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) + NotPredicate exprA -> + referencedTransactionIds exprA + RelationalExprPredicate rExpr -> + referencedTransactionIds rExpr + AtomExprPredicate aExpr -> + referencedTransactionIds aExpr + AttributeEqualityPredicate _ aExpr -> + referencedTransactionIds aExpr + +instance ReferencedTransactionIds a => ReferencedTransactionIds (ExtendTupleExprBase a) where + referencedTransactionIds (AttributeExtendTupleExpr _ aExpr) = + referencedTransactionIds aExpr + +instance ReferencedTransactionIds a => ReferencedTransactionIds (WithNameExprBase a) where + referencedTransactionIds (WithNameExpr _ marker) = referencedTransactionIds marker + +instance ReferencedTransactionIds a => ReferencedTransactionIds (AtomExprBase a) where + referencedTransactionIds expr = + case expr of + AttributeAtomExpr{} -> mempty + NakedAtomExpr{} -> mempty + FunctionAtomExpr _ args marker -> + S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args)) + RelationAtomExpr rExpr -> + referencedTransactionIds rExpr + ConstructedAtomExpr _ args marker -> + S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args)) + +-- only the relvars can reference other transactions +instance ReferencedTransactionIds DatabaseContext where + referencedTransactionIds dbc = + S.unions [ + --referencedTransactionIds (inclusionDependencies dbc), + referencedTransactionIds (relationVariables dbc) + --referencedTransactionIds (atomFunctions dbc), + --referencedTransactionIds (dbcFunctions dbc), + --referencedTransactionIds (notifications dbc), + --referencedTransactionIds (typeConstructorMapping dbc), + --referencedTransactionIds (registeredQueries dbc) + ] + +instance ReferencedTransactionIds RelationVariables where + referencedTransactionIds relVars = + S.unions (referencedTransactionIds <$> M.elems relVars) + diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs index 59eabeab..821b19d6 100644 --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -13,6 +13,7 @@ import ProjectM36.MerkleHash import qualified ProjectM36.DisconnectedTransaction as Discon import qualified ProjectM36.Attribute as A import ProjectM36.HashSecurely +import ProjectM36.ReferencedTransactionIds import Codec.Winery import Control.Monad.Except hiding (join) @@ -373,7 +374,7 @@ validateHeadName headName graph (t1, t2) = else pure trans --- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal. +-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal. The subgraph must also include any transactions which are referenced by other transactions. subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do let currentid = transactionId currentTrans' @@ -398,8 +399,15 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans trav Left err -> Left err Right currentTransParent -> subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans' traverseSet) - else -- we found a path - Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound))) + else do -- we found a path + -- we union all the relevant path transactions together, but we are missing any transactions which these transaction may reference. To make a valid transaction graph, we must include these referenced transactions. + let openSet = S.unions (traverseSet : pathsFound) + transactionIncluder acc trans = do + let allTids = referencedTransactionIds (concreteDatabaseContext trans) + allTrans <- mapM (`transactionForId` origGraph) (S.toList allTids) + pure $ S.unions (S.singleton trans : S.fromList allTrans : [acc]) + closedTransactionSet <- foldM transactionIncluder mempty (S.toList openSet) + Right (TransactionGraph resultHeads closedTransactionSet) where oneParent (Transaction _ tinfo _) = transactionForId (NE.head (parents tinfo)) origGraph @@ -437,9 +445,12 @@ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = d transB <- transactionForHeadErr headNameB disconParent <- gfTransForId parentId let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph) + -- is this an optimization??? subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty subGraph' <- runE $ filterSubGraph subGraph subHeads - mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ createMergeTransaction stamp' newId mergeStrategy (transA, transB) + -- we cannot cut the transaction graph away only to "relevant" transactions because transactions can reference other transactions via relvar expressions + mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ + createMergeTransaction stamp' newId mergeStrategy (transA, transB) case headNameForTransaction disconParent graph of Nothing -> throwError (TransactionIsNotAHeadError parentId) Just headName -> do @@ -625,3 +636,5 @@ validateMerkleHashes graph = case validateMerkleHash trans graph of Left err -> err : acc _ -> acc + + diff --git a/src/lib/ProjectM36/TransactionGraph/Merge.hs b/src/lib/ProjectM36/TransactionGraph/Merge.hs index 537d742b..5edad854 100644 --- a/src/lib/ProjectM36/TransactionGraph/Merge.hs +++ b/src/lib/ProjectM36/TransactionGraph/Merge.hs @@ -26,14 +26,14 @@ unionMergeMaps prefer mapA mapB = case prefer of unionMergeRelation :: MergePreference -> GraphRefRelationalExpr -> GraphRefRelationalExpr -> GraphRefRelationalExprM GraphRefRelationalExpr unionMergeRelation prefer relA relB = do let unioned = Union relA relB - mergeErr = MergeTransactionError StrategyViolatesRelationVariableMergeError + mergeErr e = MergeTransactionError (StrategyViolatesRelationVariableMergeError e) preferredRelVar = case prefer of PreferFirst -> pure relA PreferSecond -> pure relB - PreferNeither -> throwError mergeErr + PreferNeither -> throwError (MergeTransactionError StrategyWithoutPreferredBranchResolutionMergeError) handler AttributeNamesMismatchError{} = preferredRelVar - handler _err' = throwError mergeErr + handler err' = throwError (mergeErr err') --typecheck first? (evalGraphRefRelationalExpr unioned >> pure (Union relA relB)) `catchError` handler @@ -47,7 +47,7 @@ unionMergeRelVars prefer relvarsA relvarsB = do lookupA = findRel relvarsA lookupB = findRel relvarsB case (lookupA, lookupB) of - (Just relA, Just relB) -> + (Just relA, Just relB) -> do unionMergeRelation prefer relA relB (Nothing, Just relB) -> pure relB (Just relA, Nothing) -> pure relA diff --git a/test/TransactionGraph/Merge.hs b/test/TransactionGraph/Merge.hs index 0b293285..3a3ee42b 100644 --- a/test/TransactionGraph/Merge.hs +++ b/test/TransactionGraph/Merge.hs @@ -99,7 +99,7 @@ testSubGraphToFirstAncestorBasic = TestCase $ do transB <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB" subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph graph) transA transB S.empty let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg) - assertEqual "no graph changes" (graphEq subgraph) (graphEq graph) + assertEqual "no graph changes" (graphEq graph) (graphEq subgraph) -- | Test that a branch anchored at the root transaction is removed when using the first ancestor function. testSubGraphToFirstAncestorSnipBranch :: Test @@ -247,7 +247,7 @@ testUnionMergeStrategy = TestCase $ do gfEnv' = freshGraphRefRelationalExprEnv Nothing graph''' case failingMerge of Right _ -> assertFailure "expected merge failure" - Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError) + Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyWithoutPreferredBranchResolutionMergeError) -- test that a merge will fail if a constraint is violated testUnionMergeIncDepViolation :: Test From a0f99bcb15449e812a3fa1012aa0abeb2ea3af0b Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 19 Jan 2024 11:21:58 -0500 Subject: [PATCH 052/170] fix missing recursion in transaction referenced ids we weren't recursing parent ids, just one level of relvar tids resolves #364 --- .../ProjectM36/ReferencedTransactionIds.hs | 26 ++++++++++++++++-- src/lib/ProjectM36/TransactionGraph.hs | 27 ++++++++++++------- 2 files changed, 42 insertions(+), 11 deletions(-) diff --git a/src/lib/ProjectM36/ReferencedTransactionIds.hs b/src/lib/ProjectM36/ReferencedTransactionIds.hs index 56033428..581f662b 100644 --- a/src/lib/ProjectM36/ReferencedTransactionIds.hs +++ b/src/lib/ProjectM36/ReferencedTransactionIds.hs @@ -1,8 +1,12 @@ {-# LANGUAGE FlexibleInstances #-} module ProjectM36.ReferencedTransactionIds where import ProjectM36.Base +import ProjectM36.Error +import qualified ProjectM36.Transaction as T +import ProjectM36.RelationalExpression import qualified Data.Map as M import qualified Data.Set as S +import Control.Monad (foldM) type TransactionIds = S.Set TransactionId @@ -112,6 +116,24 @@ instance ReferencedTransactionIds DatabaseContext where ] instance ReferencedTransactionIds RelationVariables where - referencedTransactionIds relVars = - S.unions (referencedTransactionIds <$> M.elems relVars) + referencedTransactionIds relVars = + S.unions (referencedTransactionIds <$> M.elems relVars) + +-- | Recurse relvars references and transaction parents to extract a subset of relevant transactions. +-- probably could do some trimming of transactions that are not referenced by relvars, but that is rare, so probably of not much benefit +-- should be trim merge parents that don't contribute to the relvars? maybe +referencedTransactionIdsForTransaction :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction) +referencedTransactionIdsForTransaction trans graph + | parentIds == T.rootParent = pure (S.singleton trans) + | otherwise = + foldM folder (S.singleton trans) parentIds + where + parentIds = parents (transactionInfo trans) + folder acc transId' = do + trans' <- transactionForId transId' graph + transSet <- referencedTransactionIdsForTransaction trans' graph + pure (S.union acc transSet) + + + diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs index 821b19d6..2d9d229c 100644 --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -403,9 +403,8 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans trav -- we union all the relevant path transactions together, but we are missing any transactions which these transaction may reference. To make a valid transaction graph, we must include these referenced transactions. let openSet = S.unions (traverseSet : pathsFound) transactionIncluder acc trans = do - let allTids = referencedTransactionIds (concreteDatabaseContext trans) - allTrans <- mapM (`transactionForId` origGraph) (S.toList allTids) - pure $ S.unions (S.singleton trans : S.fromList allTrans : [acc]) + allTrans <- referencedTransactionIdsForTransaction trans origGraph + pure $ S.union allTrans acc closedTransactionSet <- foldM transactionIncluder mempty (S.toList openSet) Right (TransactionGraph resultHeads closedTransactionSet) where @@ -447,6 +446,8 @@ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = d let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph) -- is this an optimization??? subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty + _ <- runE $ validateConnectivity subGraph + subGraph' <- runE $ filterSubGraph subGraph subHeads -- we cannot cut the transaction graph away only to "relevant" transactions because transactions can reference other transactions via relvar expressions mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ @@ -463,18 +464,20 @@ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = d pure (newDiscon, newGraph') --TEMPORARY COPY/PASTE -showTransactionStructureX :: Transaction -> TransactionGraph -> String -showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo +showTransactionStructureX :: Bool -> Transaction -> TransactionGraph -> String +showTransactionStructureX showRelVars trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo ++ relVarsInfo where + relVarsInfo | showRelVars == False = "" + | otherwise = "\n" <> concatMap show (M.toList (relationVariables (concreteDatabaseContext trans))) headInfo = maybe "" show (headNameForTransaction trans graph) parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of Left err -> show err Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet -showGraphStructureX :: TransactionGraph -> String -showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet +showGraphStructureX :: Bool -> TransactionGraph -> String +showGraphStructureX showRelVars graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet where - folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n" + folder trans acc = acc ++ showTransactionStructureX showRelVars trans graph ++ "\n" headsInfo = show $ M.map transactionId heads -- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph. @@ -637,4 +640,10 @@ validateMerkleHashes graph = Left err -> err : acc _ -> acc - +-- | Ensure that referenced transactions remain in the graph. +validateConnectivity :: TransactionGraph -> Either RelationalError TransactionGraph +validateConnectivity graph = do + let validateTrans trans = + mapM_ (`transactionForId` graph) (referencedTransactionIds (concreteDatabaseContext trans)) + mapM_ validateTrans (transactionsForGraph graph) + pure graph From efbccf719dcec265b4b37fb7fe3d2f2344d6c52f Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 26 Jan 2024 20:02:24 -0500 Subject: [PATCH 053/170] wip compilation checkpoints exists clause --- src/bin/SQL/Interpreter/Convert.hs | 82 +++++++++++++++++++++--------- test/SQL/InterpreterTest.hs | 8 +-- 2 files changed, 61 insertions(+), 29 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 546d010b..ce66e30d 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -100,11 +100,11 @@ prettyTableContext :: TableContext -> String prettyTableContext (TableContext tMap) = "TableContext {\n" <> concatMap prettyKV (M.toList tMap) <> "}" where prettyKV (TableAlias k, (_rvexpr, _attrs, aliasMap)) = - T.unpack k <> "::\n" <> + " " <> T.unpack k <> "::\n " <> prettyColumnAliasRemapper aliasMap prettyColumnAliasRemapper :: ColumnAliasRemapper -> String -prettyColumnAliasRemapper cAMap = intercalate ", " $ map (\(realAttr, (attrAlias, colNameSet)) -> T.unpack realAttr <> ":" <> T.unpack attrAlias <> ":{" <> show colNameSet <> "}") (M.toList cAMap) +prettyColumnAliasRemapper cAMap = intercalate ", " $ map (\(realAttr, (attrAlias, colNameSet)) -> "real->" <> T.unpack realAttr <> ":alias->" <> T.unpack attrAlias <> ":alts->{" <> show colNameSet <> "}") (M.toList cAMap) @@ -130,21 +130,41 @@ tableAliasesAsWithNameAssocs = do throwSQLE :: SQLError -> ConvertM a throwSQLE = lift . throwE +type ColumnAliasRenameMap = M.Map (TableAlias, AttributeName) ColumnAlias + -- | Pass state down to subselect, but discard any state changes from the subselect processing. -withSubSelect :: ConvertM a -> ConvertM (a, TableContext) +withSubSelect :: ConvertM a -> ConvertM (a, ColumnAliasRenameMap) withSubSelect m = do state@(TableContext orig) <- get ret <- m (TableContext postSub) <- get put state -- diff the state to get just the items that were added - traceShowM ("diff orig"::String, M.keys orig) - traceShowM ("diff postSub"::String, M.keys postSub) - traceShowM ("diff1"::String, M.difference postSub orig) - let diff = M.differenceWith tctxDiff postSub orig + traceShowM ("keys orig"::String, M.keys orig) + traceShowM ("keys postSub"::String, M.keys postSub) + let tableDiffFolder acc (tAlias, (RelationVariable rv (), _ , colAliasRemapper)) = do + let convertColAliases :: ColumnAliasRemapper -> (AttributeName, (AttributeName, S.Set ColumnName)) -> ColumnAliasRenameMap -> ColumnAliasRenameMap + convertColAliases origColAlRemapper (attrName, (attrAlias,_)) acc' = + if M.member attrName origColAlRemapper then + acc' + else + M.insert (tAlias, attrName) (ColumnAlias attrAlias) acc' + case M.lookup tAlias orig of + -- new table has been added to column alias map, add all columns aliased + Nothing -> do + pure (acc <> foldr (convertColAliases mempty) mempty (M.toList colAliasRemapper)) + -- we are aware of the table, but there may have been some new columns added + Just (_,_,colAliasRemapper) -> + pure (acc <> foldr (convertColAliases colAliasRemapper) mempty (M.toList colAliasRemapper)) + x -> throwSQLE (NotSupportedError $ "unhandled withSubSelect diff: " <> T.pack (show x)) + + diff <- foldM tableDiffFolder mempty (M.toList postSub) + +{- let diff = M.differenceWith tctxDiff postSub orig tctxDiff (rexprA, attrsA, colAliasMapA) (_, _, colAliasMapB) = - Just (rexprA, attrsA, M.difference colAliasMapB colAliasMapA) - pure (ret, TableContext diff) + Just (rexprA, attrsA, M.difference colAliasMapB colAliasMapA)-} + traceShowM ("subselect diff"::String, diff) + pure (ret, diff) -- if we find a column naming conflict, generate a non-conflicting name for insertion into the column alias map generateColumnAlias :: TableAlias -> AttributeName -> ConvertM ColumnAlias @@ -300,31 +320,41 @@ findOneColumn' targetCol tcontext = do [match] -> pure match _matches -> Left (AmbiguousColumnResolutionError targetCol) --- | Search the TableContext for a column alias remapping for the given column name. -attributeNameForColumnName' :: ColumnName -> TableContext -> Either SQLError AttributeName -attributeNameForColumnName' colName tcontext@(TableContext tmap) = do - tKey <- findOneColumn' colName tcontext +-- | Search the TableContext for a column alias remapping for the given column name. This function can change the state context if column names conflict. +attributeNameForColumnName :: ColumnName -> ConvertM AttributeName +attributeNameForColumnName colName = do + tKey <- findOneColumn colName + tcontext@(TableContext tmap) <- get let (_, rvattrs, colAliases) = tmap M.! tKey --strip table prefix, if necessary colAlias@(ColumnAlias colAttr) <- case colName of ColumnName [attr] -> pure $ ColumnAlias attr - ColumnName [tname,attr] -> pure $ ColumnAlias (tname <> "." <> attr) - ColumnName{} -> Left $ ColumnResolutionError colName - traceShowM ("attributeNameForColumnName' colAlias"::String, colAliases, colAlias) + ColumnName [tname,attr] -> pure $ ColumnAlias attr + ColumnName{} -> throwSQLE $ ColumnResolutionError colName + traceShowM ("attributeNameForColumnName' colAlias"::String, colAttr, colAliases, colAlias) case M.lookup colAttr colAliases of - Just (res,_) -> pure res -- we found it, so it's valid + Just (alias,_) -> pure alias -- we found it, so it's valid Nothing -> -- look in rvattrs, so we don't need the table alias prefix. The lack of an entry in the column alias map indicates that the column was not renamed in the join condition. if colAttr `A.isAttributeNameContained` rvattrs then - pure colAttr + -- we have a matching attribute, but it could conflict with another attribute, so check for that + case findOneColumn' (ColumnName [colAttr]) tcontext of + Right _ -> pure colAttr + Left (AmbiguousColumnResolutionError{}) -> do + --we have a conflict, so insert a new column alias and return it + let tAlias = case tKey of + TableAlias tAlias -> tAlias + (ColumnAlias al) <- noteColumnMention (Just tKey) (ColumnName [tAlias,colAttr]) Nothing + traceShowM ("attributeNameForColumnName' noteColumnMention"::String, colAttr, al) + pure al --pure (T.concat [tAlias, ".", colAttr]) else case colName of ColumnName [_, col] | col `A.isAttributeNameContained` rvattrs -> -- the column has not been aliased, so we presume it can be use the column name directly pure col - _ -> traceShow ("attrNameForColName"::String) $ Left $ ColumnResolutionError colName - + _ -> traceShow ("attrNameForColName"::String) $ throwSQLE $ ColumnResolutionError colName +{- attributeNameForColumnName :: ColumnName -> ConvertM AttributeName attributeNameForColumnName colName = do s <- get @@ -334,7 +364,7 @@ attributeNameForColumnName colName = do traceStateM traceShowM ("attributeNameForColumnName"::String, colName, "->"::String, al) pure al - + -} wrapTypeF :: TypeForRelExprF -> RelationalExpr -> ConvertM Relation wrapTypeF typeF relExpr = @@ -415,7 +445,7 @@ appendWithsToTypeF typeF withAssocs relExpr = -- | Slightly different processing for subselects. convertSubSelect :: TypeForRelExprF -> Select -> ConvertM RelationalExpr convertSubSelect typeF sel = do - (ret, TableContext aliasDiff) <- withSubSelect $ do + ((applyF, tExpr), colRenames) <- withSubSelect $ do wExprs <- case withClause sel of Nothing -> pure mempty Just wClause -> do @@ -435,9 +465,11 @@ convertSubSelect typeF sel = do [] -> id _ -> With withAssocs -- add disambiguation renaming - pure (explicitWithF (withF (projF (convertExpr dfExpr)))) - traceShowM ("diff"::String, aliasDiff) -- alias is not correct- the col alias map is empty for subquery - pure ret + pure (explicitWithF . withF . projF, convertExpr dfExpr) + let renamesF = Rename (S.fromList (map renamer (M.toList colRenames))) + renamer ((TableAlias tAlias, realAttr), ColumnAlias newAttr) = + (realAttr, newAttr) + pure (applyF (renamesF tExpr)) convertSelectItem :: TypeForRelExprF -> SelectItemsConvertTask -> (Int,SelectItem) -> ConvertM SelectItemsConvertTask convertSelectItem typeF acc (c,selItem) = diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index f0ba609c..60ad5e67 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -56,10 +56,10 @@ testSelect = TestCase $ do ("SELECT city FROM s where status=20","((s where status=20){city})"), -- restriction with asterisk and qualified name ("SELECT * FROM s WHERE \"s\".\"status\"=20","(s where status=20)"), - -- join via where clause-} + -- join via where clause ("SELECT city FROM s, sp where \"s\".\"s#\" = \"sp\".\"s#\"", "((((s rename {s# as `s.s#`}) join sp) where `s.s#` = @s#){city})" - ){-, + ), -- restriction ("SELECT status,city FROM s where status>20","((s where gt(@status,20)){status,city})"), -- extension mixed with projection @@ -120,13 +120,13 @@ testSelect = TestCase $ do -- CTEs ("WITH x AS (SELECT * FROM s) SELECT * FROM x", "(with (x as s) x)"), -- SELECT with no table expression - ("SELECT 1,2,3","((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})"), + ("SELECT 1,2,3","((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})"),-} -- basic NULL -- ("SELECT NULL", "((relation{}{}:{attr_1:=Nothing}){attr_1})"), -- where exists -- complication: we need to add attribute renamers due to the subselect ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s\".\"s#\"=\"sp\".\"s#\")", - "(s where (((sp rename {s# as `sp.s#`}) where `s#`= @`sp.s#`){}))")-} + "(s where (((sp rename {s# as `sp.s#`}) where `s#`= @`sp.s#`){}))") ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just dateExamples, From 83d0feb6141e89038614bc48dcd19735afaa59d5 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 20 Feb 2024 00:11:29 -0500 Subject: [PATCH 054/170] WIP SQL tests pass --- src/bin/SQL/Interpreter/Convert.hs | 265 ++++++++++++++++++++++++----- src/bin/SQL/Interpreter/Select.hs | 2 +- test/SQL/InterpreterTest.hs | 6 +- 3 files changed, 230 insertions(+), 43 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index ce66e30d..a9d6a12a 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -1,7 +1,7 @@ --convert SQL into relational or database context expressions {-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables, TypeApplications, GeneralizedNewtypeDeriving #-} module SQL.Interpreter.Convert where -import ProjectM36.Base +import ProjectM36.Base as B import ProjectM36.Error import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A @@ -18,7 +18,8 @@ import qualified Data.Functor.Foldable as Fold import qualified Data.List.NonEmpty as NE import Control.Monad (when) import ProjectM36.DataTypes.Maybe -import Control.Monad (void) +import Data.Maybe (isJust, fromMaybe) +--import Control.Monad (void) import Control.Monad.Trans.State (StateT, get, put, runStateT, evalStateT) import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) import Control.Monad.Identity (Identity, runIdentity) @@ -38,6 +39,7 @@ data SQLError = NotSupportedError T.Text | NoSuchSQLFunctionError FuncName | DuplicateTableReferenceError TableAlias | MissingTableReferenceError TableAlias | + TableAliasMismatchError TableAlias | UnexpectedTableNameError TableName | UnexpectedColumnNameError ColumnName | ColumnResolutionError ColumnName | @@ -83,13 +85,18 @@ insertIntoColumnAliasRemap' attrName attrAlias colName remap = Left (ColumnAliasResolutionError (ColumnAlias attrName)) -- | Used to note if columns are remapped to different attributes in order to mitigate attribute naming conflicts. -insertColumnAlias :: TableAlias -> AttributeName -> AttributeAlias -> ColumnName -> ConvertM () -insertColumnAlias tAlias attrName attrAlias colName = do +insertColumnAlias :: + TableAlias -> -- table reference + AttributeName -> -- real attribute name + ColumnAlias -> -- column alias + ColumnName -> -- original reference name + ConvertM () +insertColumnAlias tAlias attrName (ColumnAlias colAlias) colName = do TableContext tmap <- get case tAlias `M.lookup` tmap of Nothing -> throwSQLE (MissingTableReferenceError tAlias) - Just (rve,attrs,remap) -> - case insertIntoColumnAliasRemap' attrName attrAlias colName remap of + Just (rve,attrs,remap) -> do + case insertIntoColumnAliasRemap' attrName colAlias colName remap of Left err -> throwSQLE err Right remap' -> do let tmap' = M.insert tAlias (rve, attrs, remap') tmap @@ -100,8 +107,8 @@ prettyTableContext :: TableContext -> String prettyTableContext (TableContext tMap) = "TableContext {\n" <> concatMap prettyKV (M.toList tMap) <> "}" where prettyKV (TableAlias k, (_rvexpr, _attrs, aliasMap)) = - " " <> T.unpack k <> "::\n " <> - prettyColumnAliasRemapper aliasMap + " " <> T.unpack k <> ":: " <> + prettyColumnAliasRemapper aliasMap <> "\n" prettyColumnAliasRemapper :: ColumnAliasRemapper -> String prettyColumnAliasRemapper cAMap = intercalate ", " $ map (\(realAttr, (attrAlias, colNameSet)) -> "real->" <> T.unpack realAttr <> ":alias->" <> T.unpack attrAlias <> ":alts->{" <> show colNameSet <> "}") (M.toList cAMap) @@ -191,8 +198,7 @@ insertTable tAlias expr rtype = do case M.lookup tAlias map' of Nothing -> do put $ TableContext $ M.insert tAlias (expr, rtype, mempty) map' - traceShowM ("insertTable"::String, tAlias) - traceStateM +-- traceShowM ("insertTable"::String, tAlias) pure mempty Just _ -> throwSQLE (DuplicateTableReferenceError tAlias) @@ -200,27 +206,115 @@ insertTable tAlias expr rtype = do noteColumnMention :: Maybe TableAlias -> ColumnName -> Maybe ColumnAlias -> ConvertM ColumnAlias noteColumnMention mTblAlias colName mColAlias = do -- find the relevant table for the key to the right table - traceShowM ("noteColumnMention"::String, colName) - tblAlias' <- case mTblAlias of + traceShowM ("noteColumnMention"::String, mTblAlias, colName) +-- traceStateM + tc@(TableContext tcontext) <- get +{- tblAlias' <- case mTblAlias of Just tblAlias -> do void $ lookupTable tblAlias pure tblAlias Nothing ->do -- scan column names for match- if there are multiple matches, return a column ambiguity error - traceShowM ("insertColumn"::String, colName) ret <- findOneColumn colName -- traceShowM ("insertColumn2", colName) - pure ret + pure ret-} -- insert into the column alias map - let newAlias = case mColAlias of - Nothing -> case colName of - ColumnName [c] -> c - ColumnName [t,c] -> t <> "." <> c - Just (ColumnAlias al) -> al +{- let colAttr = case colName of + ColumnName [c] -> c + ColumnName [t,c] -> origAttrName = case colName of ColumnName [c] -> c - ColumnName [_,c] -> c - + ColumnName [_,c] -> c-} + -- check if we already have a mention mapping + let lookupWithTableAlias (TableAlias tAlias) colAttr = do + when (isJust mTblAlias && Just (TableAlias tAlias) /= mTblAlias) (throwSQLE (TableAliasMismatchError (TableAlias tAlias))) + -- we have a specific table alias, so ensure it's valid + let tPrefixColAttr = tAlias <> "." <> colAttr + insertColAlias newAlias = do + insertColumnAlias (TableAlias tAlias) colAttr (ColumnAlias newAlias) colName + pure (ColumnAlias newAlias) + case M.lookup (TableAlias tAlias) tcontext of + Nothing -> do -- add a new colaliasremapper + insertColAlias (fromMaybe tPrefixColAttr (unColumnAlias <$> mColAlias)) + Just (_, _, colAlRemapper) -> do + -- table alias already known, check for column alias + traceShowM ("noteColumnMention before attr"::String, colAlRemapper) + case attributeNameForAttributeAlias colAttr colAlRemapper of + Left _ -> do + -- col alias missing, so add it- figure out if it needs a table prefix + --traceShowM ("findNotedColumn' in noteColumnMention"::String, colAlias) + --traceStateM + let sqlColAlias = fromMaybe colAttr (unColumnAlias <$> mColAlias) + colAlias' <- case findNotedColumn' (ColumnName [colAttr]) tc of + Left err -> -- no match, so table prefix not required + insertColAlias sqlColAlias + Right [] -> -- no match, so table prefix not required + insertColAlias sqlColAlias + Right [match] -> -- we have a match, so we need the table prefix + insertColAlias (fromMaybe tPrefixColAttr (unColumnAlias <$> mColAlias)) + Right (_:_) -> throwSQLE (AmbiguousColumnResolutionError colName) + --traceShowM ("findNotedColumn' in noteColumnMentionB"::String, colAlias') + pure colAlias' + Right attrName -> + -- we know the alias already, so return it + pure (ColumnAlias attrName) + + case colName of + ColumnName [tAlias,colAlias] -> lookupWithTableAlias (TableAlias tAlias) colAlias + ColumnName [colAlias] -> + case mTblAlias of + Just tAlias -> lookupWithTableAlias tAlias colAlias + Nothing -> do + -- lookup without table alias + -- unqualified column alias- search for unambiguous table reference + let folder (ta@(TableAlias tAlias), (_, _, colAliasRemapper)) acc = + case attributeNameForAttributeAlias colAlias colAliasRemapper of + Left _ -> acc + Right attrName -> (ta,attrName) : acc + sqlColAlias = fromMaybe colAlias (unColumnAlias <$> mColAlias) + + case foldr folder mempty (M.toList tcontext) of + [] -> do -- no matches, search raw attributes + case findColumn' colName tc of + [] -> -- no match in attributes, either, error + throwSQLE (UnexpectedColumnNameError colName) + [tAlias] -> do -- one match, insert it + insertColumnAlias tAlias sqlColAlias (ColumnAlias colAlias) colName + pure (ColumnAlias colAlias) + (_:_) -> -- too many matches, error + throwSQLE (AmbiguousColumnResolutionError colName) + [(tAlias, attrName)] -> do -- valid attribute match, so add colaliasremapper + insertColumnAlias tAlias attrName (ColumnAlias colAlias) colName + pure (ColumnAlias colAlias) + (_:_) -> -- two many matches, error + throwSQLE (AmbiguousColumnResolutionError colName) + + + +------ +{- case findNotedColumn' colName tc of + Right [] -> do + -- no match found, so we can insert this as a new column alias + let colAlias = case mColAlias of + Just al -> al + Nothing -> --ColumnAlias (unTableAlias tblAlias' <> "." <> origAttrName) + ColumnAlias origAttrName + insertColumnAlias tblAlias' origAttrName colAlias colName + pure colAlias + Right [match] -> + -- one match found- error + throwSQLE (AmbiguousColumnResolutionError colName) + Right (match:_) -> + -- multiple matches found- error + throwSQLE (AmbiguousColumnResolutionError colName) + Left (ColumnResolutionError{}) -> + throwSQLE err-} +{- case M.lookup tblAlias' tcontext of + Nothing -> throwSQLE (MissingTableReferenceError tblAlias') + Just (_,_,colAliasRemapper) -> do + case attributeNameForAttributeAlias colAttr colAliasRemapper of + Right _ -> pure (ColumnAlias colAttr) + Left _ -> do -- no match previously recorded, so add it-} {- when (newAlias `elem` allColumnAliases tcontext) $ do traceShowM ("gonk error", "colName", colName, @@ -229,9 +323,13 @@ noteColumnMention mTblAlias colName mColAlias = do p tmap) throwSQLE (DuplicateColumnAliasError newAlias)-} --duplicate column aliases are OK --verify that the alias is not duplicated - insertColumnAlias tblAlias' origAttrName newAlias colName - pure (ColumnAlias newAlias) - +{- let colAlias = case mColAlias of + Just al -> al + Nothing -> --ColumnAlias (unTableAlias tblAlias' <> "." <> origAttrName) + ColumnAlias origAttrName + insertColumnAlias tblAlias' origAttrName colAlias colName + pure colAlias +-} {- -- | Add a column alias for a column which has already been inserted into the TableContext. addColumnAlias' :: TableContext -> TableAlias -> ColumnAlias -> AttributeName -> Either SQLError TableContext @@ -305,6 +403,39 @@ findColumn' targetCol (TableContext tMap) = do acc _ -> acc +-- search ColumnAliasRemapper for columns which have already been noted- can be used for probing for new aliases +findNotedColumn' :: ColumnName -> TableContext -> Either SQLError [(TableAlias, AttributeName)] +findNotedColumn' cn@(ColumnName [attr]) (TableContext tcontext) = + -- search all column alias remappers for attribute- if there is a conflict because the alias is ambiguous, error out + pure $ foldr folder mempty (M.toList tcontext) + where + folder (ta@(TableAlias tAlias), (_, _, colAliasRemapper)) acc = + case attributeNameForAttributeAlias attr colAliasRemapper of + Left _ -> acc + Right attrName -> (ta,attrName) : acc + +findNotedColumn' (ColumnName [tPrefix, attr]) (TableContext tcontext) = + --find referenced table alias + --search for noted column in column alias remapper + case M.lookup (TableAlias tPrefix) tcontext of + Nothing -> Left (MissingTableReferenceError (TableAlias tPrefix)) + Just (_, _, colAlRemapper) -> do + attrName <- attributeNameForAttributeAlias attr colAlRemapper + pure [(TableAlias tPrefix, attrName)] + + +attributeNameForAttributeAlias :: AttributeAlias -> ColumnAliasRemapper -> Either SQLError AttributeName +attributeNameForAttributeAlias al remapper = do +-- traceShowM ("attributeNameForAttributeAlias"::String, al, remapper) + foldr folder (Left (ColumnAliasResolutionError (ColumnAlias "GONKTASTIC"))) (M.toList remapper) + where + folder (attrName, (attrAlias, _)) acc = + if attrAlias == al then + pure attrAlias + else + acc + + findOneColumn :: ColumnName -> ConvertM TableAlias findOneColumn targetCol = do tcontext <- get @@ -316,7 +447,7 @@ findOneColumn' :: ColumnName -> TableContext -> Either SQLError TableAlias findOneColumn' targetCol tcontext = do case findColumn' targetCol tcontext of [] -> do - traceShow ("findOneColumn'"::String, targetCol) $ Left (ColumnResolutionError targetCol) + Left (ColumnResolutionError targetCol) [match] -> pure match _matches -> Left (AmbiguousColumnResolutionError targetCol) @@ -331,7 +462,7 @@ attributeNameForColumnName colName = do ColumnName [attr] -> pure $ ColumnAlias attr ColumnName [tname,attr] -> pure $ ColumnAlias attr ColumnName{} -> throwSQLE $ ColumnResolutionError colName - traceShowM ("attributeNameForColumnName' colAlias"::String, colAttr, colAliases, colAlias) +-- traceShowM ("attributeNameForColumnName' colAlias"::String, colAttr, colAliases, colAlias) case M.lookup colAttr colAliases of Just (alias,_) -> pure alias -- we found it, so it's valid Nothing -> @@ -344,8 +475,9 @@ attributeNameForColumnName colName = do --we have a conflict, so insert a new column alias and return it let tAlias = case tKey of TableAlias tAlias -> tAlias + traceShowM ("attributeNameForColumnName"::String, colName) (ColumnAlias al) <- noteColumnMention (Just tKey) (ColumnName [tAlias,colAttr]) Nothing - traceShowM ("attributeNameForColumnName' noteColumnMention"::String, colAttr, al) + --traceShowM ("attributeNameForColumnName' noteColumnMention"::String, colAttr, al) pure al --pure (T.concat [tAlias, ".", colAttr]) else @@ -353,7 +485,7 @@ attributeNameForColumnName colName = do ColumnName [_, col] | col `A.isAttributeNameContained` rvattrs -> -- the column has not been aliased, so we presume it can be use the column name directly pure col - _ -> traceShow ("attrNameForColName"::String) $ throwSQLE $ ColumnResolutionError colName + _ -> throwSQLE $ ColumnResolutionError colName {- attributeNameForColumnName :: ColumnName -> ConvertM AttributeName attributeNameForColumnName colName = do @@ -427,7 +559,6 @@ convertSelect typeF sel = do _ -> With withAssocs finalRelExpr = explicitWithF (withF (projF (convertExpr dfExpr))) -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes - traceStateM -- apply rename reduction- this could be applied by the static query optimizer, but we do it here to simplify the tests so that they aren't polluted with redundant renames pure (dfExpr { convertExpr = finalRelExpr }) @@ -455,7 +586,7 @@ convertSubSelect typeF sel = do Nothing -> pure (baseDFExpr, mempty) Just tExpr -> convertTableExpr typeF' tExpr when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") - traceShowM ("convertSubSelect"::String, colMap) +-- traceShowM ("convertSubSelect"::String, colMap) let explicitWithF = if null wExprs then id else With wExprs -- convert projection using table alias map to resolve column names projF <- convertProjection typeF' (projectionClause sel) -- the projection can only project on attributes from the subselect table expression @@ -465,11 +596,17 @@ convertSubSelect typeF sel = do [] -> id _ -> With withAssocs -- add disambiguation renaming +-- traceShowM ("subselect tExpr"::String, convertExpr dfExpr) pure (explicitWithF . withF . projF, convertExpr dfExpr) - let renamesF = Rename (S.fromList (map renamer (M.toList colRenames))) + +{- let renamesF = Rename (S.fromList (map renamer (M.toList colRenames))) renamer ((TableAlias tAlias, realAttr), ColumnAlias newAttr) = - (realAttr, newAttr) - pure (applyF (renamesF tExpr)) + (realAttr, newAttr)-} + let renamedExpr = foldr renamerFolder tExpr (M.toList colRenames) + renamerFolder ((TableAlias tAlias, oldAttrName), ColumnAlias newAttrName) acc = + pushDownAttributeRename (S.singleton (oldAttrName, newAttrName)) (RelationVariable tAlias ()) acc + + pure (applyF renamedExpr) convertSelectItem :: TypeForRelExprF -> SelectItemsConvertTask -> (Int,SelectItem) -> ConvertM SelectItemsConvertTask convertSelectItem typeF acc (c,selItem) = @@ -592,6 +729,8 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do Identifier i -> wrongType TextAtomType -- could be a better error here BinaryOperator i@(Identifier colName) (OperatorName ["="]) exprMatch -> do --we don't know here if this results in a boolean expression, so we pass it down attrName <- attributeNameForColumnName colName +-- traceShowM ("convertWhereClause eq"::String, colName, attrName) +-- traceStateM AttributeEqualityPredicate attrName <$> convertScalarExpr typeF exprMatch BinaryOperator exprA op exprB -> do a <- convertScalarExpr typeF exprA @@ -725,17 +864,19 @@ joinTableRef typeF rvA (c,tref) = do prefixRenamer tAlias@(TableAlias prefix) expr attrs = do renamed <- mapM (prefixOneAttr tAlias) attrs pure (Rename (S.fromList renamed) expr) - prefixOneAttr tAlias@(TableAlias prefix) old_name = do + prefixOneAttr tAlias@(TableAlias tPrefix) old_name = do -- insert into columnAliasMap - let new_name = T.concat [prefix, ".", old_name] --- traceShowM ("prefixOneAttr", tAlias, old_name, new_name) + let new_name = T.concat [tPrefix, ".", old_name] + traceShowM ("prefixOneAttr", tAlias, old_name, new_name) (ColumnAlias alias) <- noteColumnMention (Just tAlias) (ColumnName [old_name]) (Just (ColumnAlias new_name)) - insertColumnAlias tAlias old_name new_name (ColumnName [new_name]) + traceShowM ("joinTableRef prefixOneAttr", alias) + traceStateM +-- insertColumnAlias tAlias old_name (ColumnAlias new_name) (ColumnName [new_name]) -- addColumnAlias tAlias (ColumnAlias new_name) old_name pure (old_name, alias) renameOneAttr x expr old_name = do -- traceShowM ("renameOneAttr", old_name, new_name) - insertColumnAlias (TableAlias prefix) old_name new_name (ColumnName [new_name]) + insertColumnAlias (TableAlias prefix) old_name (ColumnAlias new_name) (ColumnName [new_name]) -- addColumnAlias (TableAlias prefix) (ColumnAlias new_name) old_name pure (old_name, new_name) where @@ -906,7 +1047,53 @@ needsToRenameAllAttributes (RestrictionExpr sexpr) = ExistsExpr{} -> True {- -:showexpr relation{tuple{val 4, children relation{tuple{val 6,children relation{tuple{}}}}}, +":showexpr relation{tuple{val 4, children relation{tuple{val 6,children relation{tuple{}}}}}, tuple{val 10, children relation{tuple{val 1, children relation{tuple{}}}, tuple{val 2, children relation{tuple{}}}}}} -} + +-- rename an attribute within a relational expression +-- this really should be generalized to a standard fold or via recursion schemes +pushDownAttributeRename :: S.Set (AttributeName, AttributeName) -> RelationalExpr -> RelationalExpr -> RelationalExpr +pushDownAttributeRename renameSet matchExpr targetExpr = + case targetExpr of + _ | targetExpr == matchExpr -> + Rename renameSet targetExpr + x@MakeRelationFromExprs{} -> x + x@MakeStaticRelation{} -> x + x@ExistingRelation{} -> x + x@RelationVariable{} -> x + Project attrs expr -> Project attrs (push expr) + Union exprA exprB -> Union (push exprA) (push exprB) + Join exprA exprB -> Join (push exprA) (push exprB) + Rename rset expr -> Rename (S.union rset renameSet) (push expr) + Difference exprA exprB -> Difference (push exprA) (push exprB) + B.Group gAttrs newAttr expr -> B.Group gAttrs newAttr (push expr) + Ungroup attrName expr -> Ungroup attrName (push expr) + Restrict rExpr expr -> Restrict (pushRestrict rExpr) (push expr) + Equals exprA exprB -> Equals (push exprA) (push exprB) + NotEquals exprA exprB -> NotEquals (push exprA) (push exprB) + Extend eExpr expr -> Extend (pushExtend eExpr) (push expr) + With wAssocs expr -> With wAssocs (push expr) + where + push expr = pushDownAttributeRename renameSet matchExpr expr + pushRestrict expr = + case expr of + x@TruePredicate -> x + AndPredicate eA eB -> AndPredicate (pushRestrict eA) (pushRestrict eB) + OrPredicate eA eB -> OrPredicate (pushRestrict eA) (pushRestrict eB) + NotPredicate e -> NotPredicate (pushRestrict e) + RelationalExprPredicate rexpr -> RelationalExprPredicate (push rexpr) + AtomExprPredicate aexpr -> AtomExprPredicate (pushAtom aexpr) + AttributeEqualityPredicate attr aexpr -> AttributeEqualityPredicate attr (pushAtom aexpr) + pushExtend (AttributeExtendTupleExpr attrName aexpr) = + --should this rename the attrName, too? + AttributeExtendTupleExpr attrName (pushAtom aexpr) + pushAtom expr = + case expr of + x@AttributeAtomExpr{} -> x --potential rename + x@NakedAtomExpr{} -> x + FunctionAtomExpr fname args () -> FunctionAtomExpr fname (pushAtom <$> args) () + RelationAtomExpr e -> RelationAtomExpr (push e) + ConstructedAtomExpr dConsName args () -> ConstructedAtomExpr dConsName (pushAtom <$> args) () + diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 84cc08de..d568c5f0 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -137,7 +137,7 @@ data OperatorName = OperatorName [Text] newtype ColumnAlias = ColumnAlias { unColumnAlias :: Text } deriving (Show, Eq, Ord) -newtype TableAlias = TableAlias Text +newtype TableAlias = TableAlias { unTableAlias :: Text } deriving (Show, Eq, Ord, Monoid, Semigroup) newtype FuncName = FuncName [Text] diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 60ad5e67..f718dec8 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -47,7 +47,7 @@ testSelect = TestCase $ do (tgraph,transId) <- freshTransactionGraph dateExamples (sess, conn) <- dateExamplesConnection emptyNotificationCallback - let readTests = [{- + let readTests = [ -- simple relvar ("SELECT * FROM s", "(s)"), -- simple projection @@ -120,7 +120,7 @@ testSelect = TestCase $ do -- CTEs ("WITH x AS (SELECT * FROM s) SELECT * FROM x", "(with (x as s) x)"), -- SELECT with no table expression - ("SELECT 1,2,3","((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})"),-} + ("SELECT 1,2,3","((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})"), -- basic NULL -- ("SELECT NULL", "((relation{}{}:{attr_1:=Nothing}){attr_1})"), -- where exists @@ -157,7 +157,7 @@ testSelect = TestCase $ do --print ("selectAsRelExpr"::String, selectAsRelExpr) print ("expected: ", pretty tutdAsDFExpr) - print ("actual: ", pretty selectAsDFExpr) + print ("actual : ", pretty selectAsDFExpr) assertEqual (T.unpack sql) tutdAsDFExpr selectAsDFExpr --check that the expression can actually be executed eEvald <- executeDataFrameExpr sess conn tutdAsDFExpr From 35e6d3c7e29b9e8acb36c06cf6295a630b75df86 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Feb 2024 01:42:39 -0500 Subject: [PATCH 055/170] WIP SQL NULL tests passing --- project-m36.cabal | 2 + src/bin/SQL/Interpreter/Base.hs | 6 +- src/bin/SQL/Interpreter/Convert.hs | 19 +++-- src/bin/SQL/Interpreter/Select.hs | 13 +++- src/bin/TutorialD/tutd.hs | 4 + src/lib/ProjectM36/Client.hs | 8 +- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 83 +++++++++++++++++++++ src/lib/ProjectM36/SQLDatabaseContext.hs | 13 ++++ src/lib/ProjectM36/Server.hs | 3 +- test/SQL/InterpreterTest.hs | 93 +++++++++++++++++------- 10 files changed, 205 insertions(+), 39 deletions(-) create mode 100644 src/lib/ProjectM36/DataTypes/SQL/Null.hs create mode 100644 src/lib/ProjectM36/SQLDatabaseContext.hs diff --git a/project-m36.cabal b/project-m36.cabal index d604e4a2..3521c1b2 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -107,6 +107,8 @@ Library ProjectM36.DataTypes.Primitive, ProjectM36.DataTypes.Interval, ProjectM36.DataTypes.ByteString, + ProjectM36.DataTypes.SQL.Null, + ProjectM36.SQLDatabaseContext, ProjectM36.MiscUtils, ProjectM36.Notifications, ProjectM36.Relation, diff --git a/src/bin/SQL/Interpreter/Base.hs b/src/bin/SQL/Interpreter/Base.hs index 7b921088..867b62a1 100644 --- a/src/bin/SQL/Interpreter/Base.hs +++ b/src/bin/SQL/Interpreter/Base.hs @@ -23,8 +23,12 @@ reserved word = do reserveds :: Text -> Parser () reserveds words' = do let words'' = T.splitOn " " words' - sequence_ (map reserved words'') + reserveds' words'' +reserveds' :: [Text] -> Parser () +reserveds' words' = + sequence_ (map reserved words') + -- does not consume trailing spaces qualifiedNameSegment :: Text -> Parser Text qualifiedNameSegment sym = T.toLower <$> string' sym diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index a9d6a12a..c7661285 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -17,7 +17,6 @@ import Data.List (intercalate, find) import qualified Data.Functor.Foldable as Fold import qualified Data.List.NonEmpty as NE import Control.Monad (when) -import ProjectM36.DataTypes.Maybe import Data.Maybe (isJust, fromMaybe) --import Control.Monad (void) import Control.Monad.Trans.State (StateT, get, put, runStateT, evalStateT) @@ -737,6 +736,12 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do b <- convertScalarExpr typeF exprB f <- lookupOperator op pure (AtomExprPredicate (f [a,b])) + PostfixOperator expr (OperatorName ops) -> do + expr' <- convertScalarExpr typeF expr +-- traceShowM ("convertWhereClause"::String, expr') + case ops of + ["is", "null"] -> do + pure $ AtomExprPredicate (FunctionAtomExpr "sql_isnull" [expr'] ()) InExpr inOrNotIn sexpr (InList matches') -> do eqExpr <- convertScalarExpr typeF sexpr let (match:matches) = reverse matches' @@ -764,8 +769,10 @@ convertScalarExpr typeF expr = do IntegerLiteral i -> naked (IntegerAtom i) DoubleLiteral d -> naked (DoubleAtom d) StringLiteral s -> naked (TextAtom s) + BooleanLiteral True -> pure $ ConstructedAtomExpr "True" [] () + BooleanLiteral False -> pure $ ConstructedAtomExpr "False" [] () -- we don't have enough type context with a cast, so we default to text - NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) + NullLiteral -> pure $ ConstructedAtomExpr "SQLNull" [] () Identifier i -> do AttributeAtomExpr <$> convertColumnName i BinaryOperator exprA op exprB -> do @@ -781,7 +788,9 @@ convertProjectionScalarExpr typeF expr = do IntegerLiteral i -> naked (IntegerAtom i) DoubleLiteral d -> naked (DoubleAtom d) StringLiteral s -> naked (TextAtom s) - NullLiteral -> naked (ConstructedAtom "Nothing" (maybeAtomType TextAtomType) []) + BooleanLiteral True -> pure $ ConstructedAtomExpr "True" [] () + BooleanLiteral False -> pure $ ConstructedAtomExpr "False" [] () + NullLiteral -> pure $ ConstructedAtomExpr "SQLNull" [] () Identifier i -> AttributeAtomExpr <$> convertColumnProjectionName i BinaryOperator exprA op exprB -> do @@ -982,11 +991,11 @@ lookupFunc qname = ("<",f "lt"), (">=",f "gte"), ("<=",f "lte"), - ("=",f "eq"), + ("=",f "sql_eq"), ("!=",f "not_eq"), -- function missing ("<>",f "not_eq"), -- function missing ("+", f "add"), - ("and", f "and"), + ("and", f "sql_and"), ("or", f "or") ] diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index d568c5f0..903df9d0 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -63,12 +63,13 @@ data ScalarExprBase n = IntegerLiteral Integer | DoubleLiteral Double | StringLiteral Text + | BooleanLiteral Bool | NullLiteral -- | Interval | Identifier n | BinaryOperator (ScalarExprBase n) OperatorName (ScalarExprBase n) | PrefixOperator OperatorName (ScalarExprBase n) - | PostfixOperator (ScalarExprBase n) ColumnName + | PostfixOperator (ScalarExprBase n) OperatorName | BetweenOperator (ScalarExprBase n) (ScalarExprBase n) (ScalarExprBase n) | FunctionApplication FuncName (ScalarExprBase n) | CaseExpr { caseWhens :: [([ScalarExprBase n],ScalarExprBase n)], @@ -297,6 +298,7 @@ scalarExprOp = --binarySymbolsN ["not", "like"] ], map binarySymbolN ["<",">",">=","<=","!=","<>","="], + [postfixKeywords ["is","null"]], {- [binarySymbolsN ["is", "distinct", "from"], binarySymbolsN ["is", "not", "distinct", "from"]],-} [binarySymbolL "and"], @@ -313,6 +315,10 @@ scalarExprOp = binarySymbolR s = E.InfixR $ binary s binarySymbolN s = E.InfixN $ binary s qComparisonOp = E.Postfix $ try quantifiedComparisonSuffixP + postfixKeywords kws = E.Postfix $ do + try $ reserveds' kws + pure (\a -> PostfixOperator a (OperatorName kws)) + qualifiedOperatorP :: Text -> Parser OperatorName qualifiedOperatorP sym = @@ -379,11 +385,14 @@ comparisonOperatorP = choice (map (\(match', op) -> reserved match' $> op) ops) ("!=", OpNE)] simpleLiteralP :: Parser (ScalarExprBase a) -simpleLiteralP = try doubleLiteralP <|> integerLiteralP <|> stringLiteralP <|> nullLiteralP +simpleLiteralP = try doubleLiteralP <|> integerLiteralP <|> booleanLiteralP <|> stringLiteralP <|> nullLiteralP doubleLiteralP :: Parser (ScalarExprBase a) doubleLiteralP = DoubleLiteral <$> double +booleanLiteralP :: Parser (ScalarExprBase a) +booleanLiteralP = BooleanLiteral <$> ((reserved "true" $> True) <|> (reserved "false" $> False)) + integerLiteralP :: Parser (ScalarExprBase a) integerLiteralP = IntegerLiteral <$> integer diff --git a/src/bin/TutorialD/tutd.hs b/src/bin/TutorialD/tutd.hs index eb4d7a0b..99544dae 100644 --- a/src/bin/TutorialD/tutd.hs +++ b/src/bin/TutorialD/tutd.hs @@ -4,6 +4,8 @@ import ProjectM36.Base import ProjectM36.Client import ProjectM36.Server.ParseArgs import ProjectM36.Server +import ProjectM36.DatabaseContext +import ProjectM36.SQLDatabaseContext import System.IO import GHC.IO.Encoding import Options.Applicative @@ -44,6 +46,8 @@ opts = info (parseArgs <**> helpOption) idm connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths + --basicDatabaseContext + sqlDatabaseContext -- for testing sql functions ONLY! DO NOT COMMIT connectionInfoForConfig (RemoteInterpreterConfig remoteHost remotePort remoteDBName _ _ _) = RemoteConnectionInfo remoteDBName remoteHost (show remotePort) outputNotificationCallback headNameForConfig :: InterpreterConfig -> HeadName diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs index 47578ce3..396dad8a 100644 --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -120,7 +120,6 @@ import ProjectM36.DatabaseContextFunction as DCF import qualified ProjectM36.IsomorphicSchema as Schema import Control.Monad.State import qualified ProjectM36.RelationalExpression as RE -import ProjectM36.DatabaseContext (basicDatabaseContext) import qualified ProjectM36.TransactionGraph as Graph import ProjectM36.TransactionGraph as TG import qualified ProjectM36.Transaction as Trans @@ -193,7 +192,7 @@ data RequestTimeoutException = RequestTimeoutException instance Exception RequestTimeoutException -- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'. The database can be run within the current process or running remotely via RPC. -data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath] | +data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath] DatabaseContext | RemoteConnectionInfo DatabaseName Hostname ServiceName NotificationCallback type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification @@ -260,11 +259,10 @@ createScriptSession ghcPkgPaths = do -- | To create a 'Connection' to a remote or local database, create a 'ConnectionInfo' and call 'connectProjectM36'. connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection) --create a new in-memory database/transaction graph -connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do +connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths bootstrapDatabaseContext) = do freshId <- nextRandom tstamp <- getCurrentTime - let bootstrapContext = basicDatabaseContext - freshGraph = bootstrapTransactionGraph tstamp freshId bootstrapContext + let freshGraph = bootstrapTransactionGraph tstamp freshId bootstrapDatabaseContext case strat of --create date examples graph for now- probably should be empty context in the future NoPersistence -> do diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs new file mode 100644 index 00000000..4f04c49c --- /dev/null +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -0,0 +1,83 @@ +module ProjectM36.DataTypes.SQL.Null where +import ProjectM36.Base +import ProjectM36.AtomFunctionError +import qualified Data.Map as M +import qualified Data.HashSet as HS + +-- analogous but not equivalent to a Maybe type due to how NULLs interact with every other value + +nullAtomType :: AtomType -> AtomType +nullAtomType arg = ConstructedAtomType "SQLNullable" (M.singleton "a" arg) + +nullTypeConstructorMapping :: TypeConstructorMapping +nullTypeConstructorMapping = [(ADTypeConstructorDef "SQLNullable" ["a"], + [DataConstructorDef "SQLNull" [], + DataConstructorDef "SQLJust" [DataConstructorDefTypeVarNameArg "a"]]) + ] + +nullAtomFunctions :: AtomFunctions +nullAtomFunctions = HS.fromList [ + Function { + funcName = "sql_isnull", --this function works on any type variable, not just SQLNullable because removing the isnull function in cases where the type is clearly not SQLNullable is more difficult + funcType = [TypeVariableType "a", BoolAtomType], + funcBody = FunctionBuiltInBody $ + \case + a:[] -> pure $ BoolAtom (isNull a) + _ -> Left AtomFunctionTypeMismatchError + }, + Function { + funcName = "sql_equals", + funcType = [nullAtomType (TypeVariableType "a"), + nullAtomType (TypeVariableType "a"), + nullAtomType BoolAtomType], + funcBody = FunctionBuiltInBody nullEq + }, + Function { + funcName = "sql_and", + funcType = [TypeVariableType "a", TypeVariableType "b", BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType + funcBody = FunctionBuiltInBody nullAnd + } + ] + where + sqlNull typ = ConstructedAtom "SQLNull" typ [] + sqlNullable val typ = ConstructedAtom "SQLJust" typ [val] + isNull (ConstructedAtom dConsName _ _) | dConsName == "SQLNull" = True + isNull _ = False + nullEq :: AtomFunctionBodyType + nullEq (a@(ConstructedAtom _ typA argsA) : b@(ConstructedAtom _ _ argsB) : []) + | isNull a || isNull b = pure $ sqlNull typA + | otherwise = pure $ sqlNullable (BoolAtom $ argsA == argsB) BoolAtomType + nullEq _ = Left AtomFunctionTypeMismatchError + +isSQLBool :: Atom -> Bool +isSQLBool (ConstructedAtom dConsName BoolAtomType [_]) | dConsName == "SQLNullable" = True +isSQLBool (BoolAtom _) = True +isSQLBool _ = False + +sqlBool :: Atom -> Maybe Bool +sqlBool (ConstructedAtom dConsName BoolAtomType [BoolAtom tf]) | dConsName == "SQLJust" = Just tf +sqlBool (ConstructedAtom dConsName BoolAtomType []) | dConsName == "SQLNull" = Nothing +sqlBool (BoolAtom tf) = Just tf +sqlBool x | isSQLBool x = error "internal sqlBool type error" -- should be caught above +sqlBool _ = error "sqlBool type mismatch" + + +nullAnd :: [Atom] -> Either AtomFunctionError Atom +nullAnd [a,b] | isSQLBool a && isSQLBool b = do + let bNull = nullAtom BoolAtomType Nothing + boolF = nullAtom BoolAtomType (Just (BoolAtom False)) + pure $ case (sqlBool a, sqlBool b) of + (Nothing, Nothing) -> bNull + (Nothing, Just True) -> bNull + (Nothing, Just False) -> boolF + (Just True, Nothing) -> bNull + (Just False, Nothing) -> boolF + (Just a', Just b') -> + nullAtom BoolAtomType (Just (BoolAtom (a' && b'))) +nullAnd _ = Left AtomFunctionTypeMismatchError + +nullAtom :: AtomType -> Maybe Atom -> Atom +nullAtom aType mAtom = + case mAtom of + Nothing -> ConstructedAtom "SQLNull" (nullAtomType aType) [] + Just atom -> ConstructedAtom "SQLJust" (nullAtomType aType) [atom] diff --git a/src/lib/ProjectM36/SQLDatabaseContext.hs b/src/lib/ProjectM36/SQLDatabaseContext.hs new file mode 100644 index 00000000..82587da4 --- /dev/null +++ b/src/lib/ProjectM36/SQLDatabaseContext.hs @@ -0,0 +1,13 @@ +-- | Enables SQL-equivalent features such as NULL types in the database in addition to Project:M36 basic functions. +module ProjectM36.SQLDatabaseContext where +import ProjectM36.Base +import ProjectM36.DatabaseContext +import ProjectM36.DataTypes.SQL.Null + +sqlDatabaseContext :: DatabaseContext +sqlDatabaseContext = basicDatabaseContext { atomFunctions = + atomFunctions basicDatabaseContext <> nullAtomFunctions, + typeConstructorMapping = + typeConstructorMapping basicDatabaseContext <> nullTypeConstructorMapping + } + diff --git a/src/lib/ProjectM36/Server.hs b/src/lib/ProjectM36/Server.hs index c3475d62..576b65df 100644 --- a/src/lib/ProjectM36/Server.hs +++ b/src/lib/ProjectM36/Server.hs @@ -6,6 +6,7 @@ import ProjectM36.Server.EntryPoints import ProjectM36.Server.RemoteCallTypes import ProjectM36.Server.Config (ServerConfig(..)) import ProjectM36.FSType +import ProjectM36.DatabaseContext import Control.Concurrent.MVar (MVar) import System.IO (stderr, hPutStrLn) @@ -199,7 +200,7 @@ launchServer daemonConfig mAddr = do hPutStrLn stderr checkFSErrorMsg pure False else do - econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig)) + econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig) basicDatabaseContext) case econn of Left err -> do hPutStrLn stderr ("Failed to create database connection: " ++ show err) diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index f718dec8..4b35eb58 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -3,15 +3,18 @@ import SQL.Interpreter.Select import SQL.Interpreter.Convert --import TutorialD.Interpreter.RelationalExpr import TutorialD.Interpreter.RODatabaseContextOperator -import TutorialD.Printer -import Prettyprinter +--import TutorialD.Printer +import ProjectM36.DataTypes.SQL.Null import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph import ProjectM36.DateExamples import ProjectM36.DatabaseContext import ProjectM36.NormalizeExpr import ProjectM36.Client +import ProjectM36.SQLDatabaseContext import ProjectM36.Base +import ProjectM36.Relation +import qualified ProjectM36.Attribute as A import System.Exit import Test.HUnit import Text.Megaparsec @@ -44,10 +47,11 @@ testFindColumn = TestCase $ do testSelect :: Test testSelect = TestCase $ do -- check that SQL and tutd compile to same thing - (tgraph,transId) <- freshTransactionGraph dateExamples + let sqlDBContext = dateExamples { relationVariables = M.insert "snull" (ExistingRelation s_nullRelVar) (relationVariables dateExamples) } + (tgraph,transId) <- freshTransactionGraph sqlDBContext (sess, conn) <- dateExamplesConnection emptyNotificationCallback - let readTests = [ + let readTests = [{- -- simple relvar ("SELECT * FROM s", "(s)"), -- simple projection @@ -121,56 +125,75 @@ testSelect = TestCase $ do ("WITH x AS (SELECT * FROM s) SELECT * FROM x", "(with (x as s) x)"), -- SELECT with no table expression ("SELECT 1,2,3","((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})"), - -- basic NULL --- ("SELECT NULL", "((relation{}{}:{attr_1:=Nothing}){attr_1})"), -- where exists -- complication: we need to add attribute renamers due to the subselect ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s\".\"s#\"=\"sp\".\"s#\")", - "(s where (((sp rename {s# as `sp.s#`}) where `s#`= @`sp.s#`){}))") + "(s where (((sp rename {s# as `sp.s#`}) where `s#`= @`sp.s#`){}))"), + -- basic projection NULL + ("SELECT NULL", + "((relation{}{}:{attr_1:=SQLNull}){attr_1})"),-} + -- restriction NULL + ("SELECT * FROM s WHERE s# IS NULL", + "(s where sql_isnull(@s#))", + "(s)"), + ("SELECT * FROM snull WHERE status IS NULL", + "(snull where sql_isnull(@status))", + "(snull where s#=\"S1\")"), + ("SELECT NULL AND FALSE", + "((relation{}{}:{attr_1:=sql_and(SQLNull,False)}){attr_1})", + "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust False}})"), + ("SELECT NULL AND TRUE", + "((relation{}{}:{attr_1:=sql_and(SQLNull,True)}){attr_1})", + "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})") ] gfEnv = GraphRefRelationalExprEnv { - gre_context = Just dateExamples, + gre_context = Just sqlDBContext, gre_graph = tgraph, gre_extra = mempty } typeF expr = do let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr) runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) - check (sql, tutd) = do - print sql + parseTutd tutd = do + case parse (dataFrameP <* eof) "test" tutd of + Left err -> assertFailure (errorBundlePretty err) + Right x -> do + pure x + check (sql, equivalent_tutd, confirmation_tutd) = do + --print sql --parse SQL select <- case parse (queryExprP <* eof) "test" sql of - Left err -> error (errorBundlePretty err) + Left err -> assertFailure (errorBundlePretty err) Right x -> do - --print x + --print ("parsed SQL:"::String, x) pure x --parse tutd - tutdAsDFExpr <- case parse (dataFrameP <* eof) "test" tutd of - Left err -> error (errorBundlePretty err) - Right x -> do - --print x - pure x + tutdAsDFExpr <- parseTutd equivalent_tutd selectAsDFExpr <- case evalConvertM mempty (convertSelect typeF select) of - Left err -> error (show err) + Left err -> assertFailure (show err) Right x -> do - print x + --print ("convert SQL->tutd:"::String, x) pure x + confirmationDFExpr <- parseTutd confirmation_tutd --print ("selectAsRelExpr"::String, selectAsRelExpr) - print ("expected: ", pretty tutdAsDFExpr) - print ("actual : ", pretty selectAsDFExpr) + --print ("expected: "::String, pretty tutdAsDFExpr) + --print ("actual : "::String, pretty selectAsDFExpr) assertEqual (T.unpack sql) tutdAsDFExpr selectAsDFExpr --check that the expression can actually be executed eEvald <- executeDataFrameExpr sess conn tutdAsDFExpr case eEvald of Left err -> assertFailure (show err <> ": " <> show tutdAsDFExpr) Right _ -> pure () - mapM_ check readTests + eConfirmationEvald <- executeDataFrameExpr sess conn confirmationDFExpr + case eConfirmationEvald of + Left err -> assertFailure (show err <> ": " <> show confirmationDFExpr) + Right _ -> pure () + mapM_ check readTests -- assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") - dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection) dateExamplesConnection callback = do - dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback []) + dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback [] sqlDatabaseContext) case dbconn of Left err -> error (show err) Right conn -> do @@ -179,10 +202,30 @@ dateExamplesConnection callback = do Left err -> error (show err) Right sessionId -> do executeDatabaseContextExpr sessionId conn (databaseContextAsDatabaseContextExpr dateExamples) >>= eitherFail - --skipping atom functions for now- there are no atom function manipulation operators yet + --add a relvar with some nulls + executeDatabaseContextExpr sessionId conn addNullTable >>= eitherFail commit sessionId conn >>= eitherFail pure (sessionId, conn) + eitherFail :: Either RelationalError a -> IO () eitherFail (Left err) = assertFailure (show err) eitherFail (Right _) = pure () + +addNullTable :: DatabaseContextExpr +addNullTable = Assign "snull" (ExistingRelation s_nullRelVar) + +s_nullRelVar :: Relation +s_nullRelVar = + case mkRelationFromList attrs atomMatrix of + Left err -> error (show err) + Right rel -> rel + where + attrs = A.attributesFromList [Attribute "s#" TextAtomType, + Attribute "sname" TextAtomType, + Attribute "status" IntegerAtomType, + Attribute "city" (nullAtomType TextAtomType)] + atomMatrix = [ + [TextAtom "S1", TextAtom "Smith", IntegerAtom 20, nullAtom TextAtomType (Just (TextAtom "London"))], + [TextAtom "S2", TextAtom "Jones", IntegerAtom 10, nullAtom TextAtomType Nothing] + ] From 25ba49b530ebd66b3f8bc3300198bf1d6ea2ed41 Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 1 Mar 2024 23:35:02 -0500 Subject: [PATCH 056/170] add equality instance to DataFrame comment out traceShows in Convert add sql_equals and sql_coalesce_bool functions --- src/bin/SQL/Interpreter/Convert.hs | 36 +++--- src/lib/ProjectM36/DataFrame.hs | 16 ++- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 33 +++-- test/SQL/InterpreterTest.hs | 147 +++++++++++++++++------ 4 files changed, 168 insertions(+), 64 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index c7661285..aeb46aa0 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -205,7 +205,7 @@ insertTable tAlias expr rtype = do noteColumnMention :: Maybe TableAlias -> ColumnName -> Maybe ColumnAlias -> ConvertM ColumnAlias noteColumnMention mTblAlias colName mColAlias = do -- find the relevant table for the key to the right table - traceShowM ("noteColumnMention"::String, mTblAlias, colName) +-- traceShowM ("noteColumnMention"::String, mTblAlias, colName) -- traceStateM tc@(TableContext tcontext) <- get {- tblAlias' <- case mTblAlias of @@ -237,7 +237,7 @@ noteColumnMention mTblAlias colName mColAlias = do insertColAlias (fromMaybe tPrefixColAttr (unColumnAlias <$> mColAlias)) Just (_, _, colAlRemapper) -> do -- table alias already known, check for column alias - traceShowM ("noteColumnMention before attr"::String, colAlRemapper) +-- traceShowM ("noteColumnMention before attr"::String, colAlRemapper) case attributeNameForAttributeAlias colAttr colAlRemapper of Left _ -> do -- col alias missing, so add it- figure out if it needs a table prefix @@ -453,7 +453,7 @@ findOneColumn' targetCol tcontext = do -- | Search the TableContext for a column alias remapping for the given column name. This function can change the state context if column names conflict. attributeNameForColumnName :: ColumnName -> ConvertM AttributeName attributeNameForColumnName colName = do - tKey <- findOneColumn colName + tKey@(TableAlias tAlias) <- findOneColumn colName tcontext@(TableContext tmap) <- get let (_, rvattrs, colAliases) = tmap M.! tKey --strip table prefix, if necessary @@ -472,9 +472,7 @@ attributeNameForColumnName colName = do Right _ -> pure colAttr Left (AmbiguousColumnResolutionError{}) -> do --we have a conflict, so insert a new column alias and return it - let tAlias = case tKey of - TableAlias tAlias -> tAlias - traceShowM ("attributeNameForColumnName"::String, colName) +-- traceShowM ("attributeNameForColumnName"::String, colName) (ColumnAlias al) <- noteColumnMention (Just tKey) (ColumnName [tAlias,colAttr]) Nothing --traceShowM ("attributeNameForColumnName' noteColumnMention"::String, colAttr, al) pure al @@ -721,6 +719,7 @@ convertWhereClause :: TypeForRelExprF -> RestrictionExpr -> ConvertM Restriction convertWhereClause typeF (RestrictionExpr rexpr) = do let wrongType t = throwSQLE $ TypeMismatchError t BoolAtomType --must be boolean expression attrName' (ColumnName ts) = T.intercalate "." ts + coalesceBool expr = FunctionAtomExpr "sql_coalesce_bool" [expr] () case rexpr of IntegerLiteral{} -> wrongType IntegerAtomType DoubleLiteral{} -> wrongType DoubleAtomType @@ -730,18 +729,19 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do attrName <- attributeNameForColumnName colName -- traceShowM ("convertWhereClause eq"::String, colName, attrName) -- traceStateM - AttributeEqualityPredicate attrName <$> convertScalarExpr typeF exprMatch + expr' <- convertScalarExpr typeF exprMatch + pure (AttributeEqualityPredicate attrName (coalesceBool expr')) BinaryOperator exprA op exprB -> do a <- convertScalarExpr typeF exprA b <- convertScalarExpr typeF exprB f <- lookupOperator op - pure (AtomExprPredicate (f [a,b])) + pure (AtomExprPredicate (coalesceBool (f [a,b]))) PostfixOperator expr (OperatorName ops) -> do expr' <- convertScalarExpr typeF expr -- traceShowM ("convertWhereClause"::String, expr') case ops of ["is", "null"] -> do - pure $ AtomExprPredicate (FunctionAtomExpr "sql_isnull" [expr'] ()) + pure $ AtomExprPredicate (coalesceBool (FunctionAtomExpr "sql_isnull" [expr'] ())) InExpr inOrNotIn sexpr (InList matches') -> do eqExpr <- convertScalarExpr typeF sexpr let (match:matches) = reverse matches' @@ -876,10 +876,10 @@ joinTableRef typeF rvA (c,tref) = do prefixOneAttr tAlias@(TableAlias tPrefix) old_name = do -- insert into columnAliasMap let new_name = T.concat [tPrefix, ".", old_name] - traceShowM ("prefixOneAttr", tAlias, old_name, new_name) +-- traceShowM ("prefixOneAttr", tAlias, old_name, new_name) (ColumnAlias alias) <- noteColumnMention (Just tAlias) (ColumnName [old_name]) (Just (ColumnAlias new_name)) - traceShowM ("joinTableRef prefixOneAttr", alias) - traceStateM +-- traceShowM ("joinTableRef prefixOneAttr", alias) +-- traceStateM -- insertColumnAlias tAlias old_name (ColumnAlias new_name) (ColumnName [new_name]) -- addColumnAlias tAlias (ColumnAlias new_name) old_name pure (old_name, alias) @@ -969,7 +969,7 @@ joinTableRef typeF rvA (c,tref) = do else new_name joinName = firstAvailableName (1::Int) allAttrs - extender = AttributeExtendTupleExpr joinName joinRe + extender = AttributeExtendTupleExpr joinName (FunctionAtomExpr "sql_coalesce_bool" [joinRe] ()) joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA)))) @@ -991,12 +991,12 @@ lookupFunc qname = ("<",f "lt"), (">=",f "gte"), ("<=",f "lte"), - ("=",f "sql_eq"), - ("!=",f "not_eq"), -- function missing - ("<>",f "not_eq"), -- function missing - ("+", f "add"), + ("=",f "sql_equals"), + ("!=",f "sql_not_equals"), -- function missing + ("<>",f "sql_not_equals"), -- function missing + ("+", f "sql_add"), ("and", f "sql_and"), - ("or", f "or") + ("or", f "sql_or") ] -- | Used in join condition detection necessary for renames to enable natural joins. diff --git a/src/lib/ProjectM36/DataFrame.hs b/src/lib/ProjectM36/DataFrame.hs index 75fb418a..d1d523aa 100644 --- a/src/lib/ProjectM36/DataFrame.hs +++ b/src/lib/ProjectM36/DataFrame.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DerivingVia #-} +{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} {- A dataframe is a strongly-typed, ordered list of named tuples. A dataframe differs from a relation in that its tuples are ordered.-} module ProjectM36.DataFrame where import ProjectM36.Base @@ -14,6 +14,8 @@ import qualified Data.Vector as V import GHC.Generics import qualified Data.List as L import qualified Data.Set as S +import qualified Data.HashSet as HS +import Data.Hashable (Hashable) import Data.Maybe import qualified Data.Text as T import Control.Arrow @@ -47,8 +49,18 @@ data DataFrame = DataFrame { } deriving (Show, Generic) +-- if there is no ordering, then compare sets of tuples +instance Eq DataFrame where + dfA == dfB = + attributes dfA == attributes dfB && + orders dfA == orders dfB && + if null (orders dfA) && null (orders dfB) then + HS.fromList (tuples dfA) == HS.fromList (tuples dfB) + else + tuples dfA == tuples dfB + data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom) - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Hashable) sortDataFrameBy :: [AttributeOrder] -> DataFrame -> Either RelationalError DataFrame sortDataFrameBy attrOrders frame = do diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index 4f04c49c..519b437d 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -3,6 +3,7 @@ import ProjectM36.Base import ProjectM36.AtomFunctionError import qualified Data.Map as M import qualified Data.HashSet as HS +import ProjectM36.DataTypes.Primitive -- analogous but not equivalent to a Maybe type due to how NULLs interact with every other value @@ -27,8 +28,8 @@ nullAtomFunctions = HS.fromList [ }, Function { funcName = "sql_equals", - funcType = [nullAtomType (TypeVariableType "a"), - nullAtomType (TypeVariableType "a"), + funcType = [TypeVariableType "a", + TypeVariableType "a", nullAtomType BoolAtomType], funcBody = FunctionBuiltInBody nullEq }, @@ -36,31 +37,49 @@ nullAtomFunctions = HS.fromList [ funcName = "sql_and", funcType = [TypeVariableType "a", TypeVariableType "b", BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType funcBody = FunctionBuiltInBody nullAnd + }, + Function { + funcName = "sql_coalesce_bool", -- used in where clause so that NULLs are filtered out + funcType = [TypeVariableType "a", + BoolAtomType], + funcBody = FunctionBuiltInBody coalesceBool } ] where sqlNull typ = ConstructedAtom "SQLNull" typ [] - sqlNullable val typ = ConstructedAtom "SQLJust" typ [val] + sqlNullable val typ = ConstructedAtom "SQLJust" (nullAtomType typ) [val] isNull (ConstructedAtom dConsName _ _) | dConsName == "SQLNull" = True isNull _ = False nullEq :: AtomFunctionBodyType nullEq (a@(ConstructedAtom _ typA argsA) : b@(ConstructedAtom _ _ argsB) : []) | isNull a || isNull b = pure $ sqlNull typA | otherwise = pure $ sqlNullable (BoolAtom $ argsA == argsB) BoolAtomType + nullEq (a:b:[]) | atomTypeForAtom a == atomTypeForAtom b = pure (sqlNullable (BoolAtom (a == b)) BoolAtomType) nullEq _ = Left AtomFunctionTypeMismatchError +coalesceBool :: [Atom] -> Either AtomFunctionError Atom +coalesceBool [arg] = case sqlBool arg of + Nothing -> pure (BoolAtom False) + Just tf -> pure (BoolAtom tf) +coalesceBool _ = Left AtomFunctionTypeMismatchError + isSQLBool :: Atom -> Bool isSQLBool (ConstructedAtom dConsName BoolAtomType [_]) | dConsName == "SQLNullable" = True isSQLBool (BoolAtom _) = True isSQLBool _ = False sqlBool :: Atom -> Maybe Bool -sqlBool (ConstructedAtom dConsName BoolAtomType [BoolAtom tf]) | dConsName == "SQLJust" = Just tf -sqlBool (ConstructedAtom dConsName BoolAtomType []) | dConsName == "SQLNull" = Nothing +sqlBool (ConstructedAtom dConsName aType [BoolAtom tf]) | + dConsName == "SQLJust" && + (aType == nullAtomType BoolAtomType || + aType == nullAtomType (TypeVariableType "a")) = Just tf +sqlBool (ConstructedAtom dConsName aType []) | + dConsName == "SQLNull" && + (aType == nullAtomType BoolAtomType || + aType == nullAtomType (TypeVariableType "a")) = Nothing sqlBool (BoolAtom tf) = Just tf sqlBool x | isSQLBool x = error "internal sqlBool type error" -- should be caught above -sqlBool _ = error "sqlBool type mismatch" - +sqlBool other = error ("sqlBool type mismatch: " <> show other) nullAnd :: [Atom] -> Either AtomFunctionError Atom nullAnd [a,b] | isSQLBool a && isSQLBool b = do diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 4b35eb58..24b56db5 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -53,57 +53,103 @@ testSelect = TestCase $ do let readTests = [{- -- simple relvar - ("SELECT * FROM s", "(s)"), + ("SELECT * FROM s", "(s)", "(s)"), -- simple projection - ("SELECT city FROM s", "(s{city})"), + ("SELECT city FROM s", "(s{city})", "(s{city})"), -- restriction - ("SELECT city FROM s where status=20","((s where status=20){city})"), + ("SELECT city FROM s where status=20", + "((s where status=20){city})", + "((s where status=20){city})" + ), -- restriction with asterisk and qualified name - ("SELECT * FROM s WHERE \"s\".\"status\"=20","(s where status=20)"), + ("SELECT * FROM s WHERE \"s\".\"status\"=20", + "(s where status=20)", + "(s where status=20)"), -- join via where clause ("SELECT city FROM s, sp where \"s\".\"s#\" = \"sp\".\"s#\"", - "((((s rename {s# as `s.s#`}) join sp) where `s.s#` = @s#){city})" + "((((s rename {s# as `s.s#`}) join sp) where `s.s#` = @s#){city})", + "(s{city} where city=\"London\" or city=\"Paris\")" ), -- restriction - ("SELECT status,city FROM s where status>20","((s where gt(@status,20)){status,city})"), + ("SELECT status,city FROM s where status>20", + "((s where gt(@status,20)){status,city})", + "((s where s#=\"S3\" or s#=\"S5\"){status,city})"), -- extension mixed with projection - ("SELECT city,status,10 FROM s","((s:{attr_3:=10}){city,status,attr_3})"), + ("SELECT city,status,10 FROM s", + "((s:{attr_3:=10}){city,status,attr_3})", + "((s:{attr_3:=10}){city,status,attr_3})" + ), -- column alias - ("SELECT city AS x FROM s","((s rename {city as x}){x})"), + ("SELECT city AS x FROM s", + "((s rename {city as x}){x})", + "((s rename {city as x}){x})" + ), -- case insensitivity - ("sElECt CitY aS X FRoM s","((s rename {city as x}){x})"), + ("sElECt CitY aS X FRoM s", + "((s rename {city as x}){x})", + "((s rename {city as x}){x})" + ), --column from aliased table - ("SELECT sup.city FROM s AS sup","(with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`}))"), + ("SELECT sup.city FROM s AS sup", + "(with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`}))", + "((s rename {city as `sup.city`}){`sup.city`})"), --projection with alias - ("SELECT sup.city,sup.sname FROM s AS sup","(with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`}))"), - ("SELECT sup.* FROM s as sup","(with (sup as s) (sup{all from sup}))"), + ("SELECT sup.city,sup.sname FROM s AS sup", + "(with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`}))", + "((s rename {city as `sup.city`, sname as `sup.sname`}){`sup.city`,`sup.sname`})" + ), + ("SELECT sup.* FROM s as sup", + "(with (sup as s) (sup{all from sup}))", + "(s)" + ), -- natural join - ("SELECT * FROM s NATURAL JOIN sp","(s join sp)"), + ("SELECT * FROM s NATURAL JOIN sp", + "(s join sp)", + "(s join sp)"), -- cross join - ("SELECT * FROM s CROSS JOIN sp", "((s rename {s# as `s.s#`}) join sp)"), + ("SELECT * FROM s CROSS JOIN sp", + "((s rename {s# as `s.s#`}) join sp)", + "((s rename {s# as `s.s#`}) join sp)"), -- unaliased join using ("SELECT * FROM sp INNER JOIN sp AS sp2 USING (\"s#\")", - "(with (sp2 as sp) ((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join (sp2 rename {p# as `sp2.p#`, qty as `sp2.qty`})))"), + "(with (sp2 as sp) ((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join (sp2 rename {p# as `sp2.p#`, qty as `sp2.qty`})))", + "(with (sp2 as sp) ((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join (sp2 rename {p# as `sp2.p#`, qty as `sp2.qty`})))"),-} -- unaliased join - ("SELECT * FROM sp JOIN s ON s.s# = sp.s#","(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=eq(@`s.s#`,@`sp.s#`)}) where join_1=True) {all but join_1})"), + ("SELECT * FROM sp JOIN s ON s.s# = sp.s#", + "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_equals(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})", + "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_equals(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})" + ), -- aliased join on ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#", - "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})"), + "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})", + "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})"), -- formula extension - ("SELECT status+10 FROM s", "((s : {attr_1:=add(@status,10)}) { attr_1 })"), + ("SELECT status+10 FROM s", + "((s : {attr_1:=add(@status,10)}) { attr_1 })", + "((s : {attr_1:=add(@status,10)}) { attr_1 })"), -- extension and formula - ("SELECT status+10,city FROM s", "((s : {attr_1:=add(@status,10)}) {city,attr_1})"), + ("SELECT status+10,city FROM s", + "((s : {attr_1:=add(@status,10)}) {city,attr_1})", + "((s : {attr_1:=add(@status,10)}) {city,attr_1})"), -- complex join condition ("SELECT * FROM sp JOIN s ON s.s# = sp.s# AND s.s# = sp.s#", - "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=and(eq(@`s.s#`,@`sp.s#`),eq(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})"), + "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_and(sql_equals(@`s.s#`,@`sp.s#`),eq(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})", + "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=and(eq(@`s.s#`,@`sp.s#`),eq(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})"), -- TABLE - ("TABLE s", "(s)"), + ("TABLE s", + "(s)", + "(s)"), -- any, all, some -- IN() - ("SELECT * FROM s WHERE s# IN ('S1','S2')", "(s where eq(@s#,\"S1\") or eq(@s#,\"S2\"))"), + ("SELECT * FROM s WHERE s# IN ('S1','S2')", + "(s where eq(@s#,\"S1\") or eq(@s#,\"S2\"))", + "(s where eq(@s#,\"S1\") or eq(@s#,\"S2\"))" + ), -- NOT IN() ("SELECT * FROM s WHERE s# NOT IN ('S1','S2')", - "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))"), + "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))", + "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))" + ), -- where not exists -- group by -- group by having @@ -112,26 +158,51 @@ testSelect = TestCase $ do -- union -- intersect -- except - ("SELECT * FROM s LIMIT 10","(s) limit 10"), + ("SELECT * FROM s LIMIT 10", + "(s) limit 10", + "(s) limit 10" + ), -- offset - ("SELECT * FROM s OFFSET 10","(s) offset 10"), + ("SELECT * FROM s OFFSET 10", + "(s) offset 10", + "(s) offset 10" + ), -- limit offset - ("SELECT * FROM s LIMIT 10 OFFSET 20","(s) limit 10 offset 20"), + ("SELECT * FROM s LIMIT 10 OFFSET 20", + "(s) limit 10 offset 20", + "(s) limit 10 offset 20" + ), -- order by - ("SELECT * FROM s ORDER BY status","(s) orderby {status}"), + ("SELECT * FROM s ORDER BY status", + "(s) orderby {status}", + "(s) orderby {status}" + ), -- order by descending - ("SELECT * FROM s ORDER BY status DESC,city","(s) orderby {status descending,city}"), + ("SELECT * FROM s ORDER BY status DESC,city", + "(s) orderby {status descending,city}", + "(s) orderby {status descending,city}" + ), -- CTEs - ("WITH x AS (SELECT * FROM s) SELECT * FROM x", "(with (x as s) x)"), + ("WITH x AS (SELECT * FROM s) SELECT * FROM x", + "(with (x as s) x)", + "(s)" + ), -- SELECT with no table expression - ("SELECT 1,2,3","((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})"), + ("SELECT 1,2,3", + "((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})", + "relation{tuple{attr_1 1, attr_2 2, attr_3 3}}" + ), -- where exists -- complication: we need to add attribute renamers due to the subselect ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s\".\"s#\"=\"sp\".\"s#\")", - "(s where (((sp rename {s# as `sp.s#`}) where `s#`= @`sp.s#`){}))"), + "(s where (((sp rename {s# as `sp.s#`}) where `s#`= @`sp.s#`){}))", + "s where not (s#=\"S5\")" + ), -- basic projection NULL ("SELECT NULL", - "((relation{}{}:{attr_1:=SQLNull}){attr_1})"),-} + "((relation{}{}:{attr_1:=SQLNull}){attr_1})", + "((true:{attr_1:=SQLNull}){attr_1})" + ), -- restriction NULL ("SELECT * FROM s WHERE s# IS NULL", "(s where sql_isnull(@s#))", @@ -159,7 +230,7 @@ testSelect = TestCase $ do Right x -> do pure x check (sql, equivalent_tutd, confirmation_tutd) = do - --print sql + print sql --parse SQL select <- case parse (queryExprP <* eof) "test" sql of Left err -> assertFailure (errorBundlePretty err) @@ -181,13 +252,15 @@ testSelect = TestCase $ do assertEqual (T.unpack sql) tutdAsDFExpr selectAsDFExpr --check that the expression can actually be executed eEvald <- executeDataFrameExpr sess conn tutdAsDFExpr - case eEvald of + sqlResult <- case eEvald of Left err -> assertFailure (show err <> ": " <> show tutdAsDFExpr) - Right _ -> pure () + Right rel -> pure rel eConfirmationEvald <- executeDataFrameExpr sess conn confirmationDFExpr - case eConfirmationEvald of + print ("confirmation"::String, confirmation_tutd) + confirmationResult <- case eConfirmationEvald of Left err -> assertFailure (show err <> ": " <> show confirmationDFExpr) - Right _ -> pure () + Right rel -> pure rel + assertEqual "SQL result confirmation" confirmationResult sqlResult mapM_ check readTests -- assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") From 62e46631180340180788527976cd41d865cf38af Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 3 Mar 2024 23:44:04 -0500 Subject: [PATCH 057/170] WIP all tests pass --- src/bin/SQL/Interpreter/Convert.hs | 20 +++---- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 62 ++++++++++++++++++---- src/lib/ProjectM36/RelationalExpression.hs | 4 +- test/SQL/InterpreterTest.hs | 53 +++++++++--------- 4 files changed, 91 insertions(+), 48 deletions(-) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index aeb46aa0..42d33fe6 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -5,11 +5,11 @@ import ProjectM36.Base as B import ProjectM36.Error import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A +import ProjectM36.Relation (attributes) import qualified ProjectM36.Attribute as A import SQL.Interpreter.Select import qualified Data.Text as T import qualified ProjectM36.WithNameExpr as With -import ProjectM36.Relation import Control.Monad (foldM) import qualified Data.Set as S import qualified Data.Map as M @@ -146,8 +146,8 @@ withSubSelect m = do (TableContext postSub) <- get put state -- diff the state to get just the items that were added - traceShowM ("keys orig"::String, M.keys orig) - traceShowM ("keys postSub"::String, M.keys postSub) +-- traceShowM ("keys orig"::String, M.keys orig) +-- traceShowM ("keys postSub"::String, M.keys postSub) let tableDiffFolder acc (tAlias, (RelationVariable rv (), _ , colAliasRemapper)) = do let convertColAliases :: ColumnAliasRemapper -> (AttributeName, (AttributeName, S.Set ColumnName)) -> ColumnAliasRenameMap -> ColumnAliasRenameMap convertColAliases origColAlRemapper (attrName, (attrAlias,_)) acc' = @@ -169,7 +169,7 @@ withSubSelect m = do {- let diff = M.differenceWith tctxDiff postSub orig tctxDiff (rexprA, attrsA, colAliasMapA) (_, _, colAliasMapB) = Just (rexprA, attrsA, M.difference colAliasMapB colAliasMapA)-} - traceShowM ("subselect diff"::String, diff) +-- traceShowM ("subselect diff"::String, diff) pure (ret, diff) -- if we find a column naming conflict, generate a non-conflicting name for insertion into the column alias map @@ -528,7 +528,7 @@ tableAliasForColumnName typeF qn@(ColumnName [colName]) (TableContext tMap) = do else pure Nothing -} baseDFExpr :: DataFrameExpr -baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () []), +baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () [TupleExpr mempty]), --relationTrue if the table expression is empty "SELECT 1" orderExprs = [], offset = Nothing, limit = Nothing } @@ -730,7 +730,7 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do -- traceShowM ("convertWhereClause eq"::String, colName, attrName) -- traceStateM expr' <- convertScalarExpr typeF exprMatch - pure (AttributeEqualityPredicate attrName (coalesceBool expr')) + pure (AtomExprPredicate (coalesceBool (FunctionAtomExpr "sql_equals" [AttributeAtomExpr attrName, expr'] ()))) BinaryOperator exprA op exprB -> do a <- convertScalarExpr typeF exprA b <- convertScalarExpr typeF exprB @@ -987,10 +987,10 @@ lookupFunc qname = Just match -> pure match where f n args = FunctionAtomExpr n args () - sqlFuncs = [(">",f "gt"), - ("<",f "lt"), - (">=",f "gte"), - ("<=",f "lte"), + sqlFuncs = [(">",f "sql_gt"), + ("<",f "sql_lt"), + (">=",f "sql_gte"), + ("<=",f "sql_lte"), ("=",f "sql_equals"), ("!=",f "sql_not_equals"), -- function missing ("<>",f "sql_not_equals"), -- function missing diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index 519b437d..a20a14c8 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -24,7 +24,7 @@ nullAtomFunctions = HS.fromList [ funcBody = FunctionBuiltInBody $ \case a:[] -> pure $ BoolAtom (isNull a) - _ -> Left AtomFunctionTypeMismatchError + _ -> error "isnull" -- $ Left AtomFunctionTypeMismatchError }, Function { funcName = "sql_equals", @@ -35,7 +35,7 @@ nullAtomFunctions = HS.fromList [ }, Function { funcName = "sql_and", - funcType = [TypeVariableType "a", TypeVariableType "b", BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType + funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType funcBody = FunctionBuiltInBody nullAnd }, Function { @@ -43,30 +43,51 @@ nullAtomFunctions = HS.fromList [ funcType = [TypeVariableType "a", BoolAtomType], funcBody = FunctionBuiltInBody coalesceBool + }, + Function { + funcName = "sql_add", + funcType = [TypeVariableType "a", + TypeVariableType "b", + nullAtomType IntegerAtomType], + funcBody = FunctionBuiltInBody (sqlIntegerBinaryFunction IntegerAtomType (\a b -> IntegerAtom (a + b))) + }, + Function { + funcName = "sql_gt", + funcType = [TypeVariableType "a", + TypeVariableType "b", + nullAtomType BoolAtomType], + funcBody = FunctionBuiltInBody (sqlIntegerBinaryFunction BoolAtomType (\a b -> BoolAtom (a > b))) + }, + Function { + funcName = "sql_gte", + funcType = [TypeVariableType "a", + TypeVariableType "b", + nullAtomType IntegerAtomType], + funcBody = FunctionBuiltInBody (sqlIntegerBinaryFunction BoolAtomType (\a b -> BoolAtom (a >= b))) } + ] where sqlNull typ = ConstructedAtom "SQLNull" typ [] sqlNullable val typ = ConstructedAtom "SQLJust" (nullAtomType typ) [val] - isNull (ConstructedAtom dConsName _ _) | dConsName == "SQLNull" = True - isNull _ = False nullEq :: AtomFunctionBodyType nullEq (a@(ConstructedAtom _ typA argsA) : b@(ConstructedAtom _ _ argsB) : []) | isNull a || isNull b = pure $ sqlNull typA | otherwise = pure $ sqlNullable (BoolAtom $ argsA == argsB) BoolAtomType - nullEq (a:b:[]) | atomTypeForAtom a == atomTypeForAtom b = pure (sqlNullable (BoolAtom (a == b)) BoolAtomType) - nullEq _ = Left AtomFunctionTypeMismatchError + nullEq [a,b] | atomTypeForAtom a == atomTypeForAtom b = pure (sqlNullable (BoolAtom (a == b)) BoolAtomType) + nullEq _other = Left AtomFunctionTypeMismatchError coalesceBool :: [Atom] -> Either AtomFunctionError Atom coalesceBool [arg] = case sqlBool arg of Nothing -> pure (BoolAtom False) Just tf -> pure (BoolAtom tf) -coalesceBool _ = Left AtomFunctionTypeMismatchError +coalesceBool _other = Left AtomFunctionTypeMismatchError isSQLBool :: Atom -> Bool -isSQLBool (ConstructedAtom dConsName BoolAtomType [_]) | dConsName == "SQLNullable" = True -isSQLBool (BoolAtom _) = True -isSQLBool _ = False +isSQLBool atom = case atomTypeForAtom atom of + ConstructedAtomType "SQLNullable" _ -> True + BoolAtomType -> True + _ -> False sqlBool :: Atom -> Maybe Bool sqlBool (ConstructedAtom dConsName aType [BoolAtom tf]) | @@ -93,10 +114,29 @@ nullAnd [a,b] | isSQLBool a && isSQLBool b = do (Just False, Nothing) -> boolF (Just a', Just b') -> nullAtom BoolAtomType (Just (BoolAtom (a' && b'))) -nullAnd _ = Left AtomFunctionTypeMismatchError +nullAnd _other = Left AtomFunctionTypeMismatchError nullAtom :: AtomType -> Maybe Atom -> Atom nullAtom aType mAtom = case mAtom of Nothing -> ConstructedAtom "SQLNull" (nullAtomType aType) [] Just atom -> ConstructedAtom "SQLJust" (nullAtomType aType) [atom] + +isNullOrType :: AtomType -> Atom -> Bool +isNullOrType aType atom = atomTypeForAtom atom == nullAtomType aType || atomTypeForAtom atom == aType + +isNull :: Atom -> Bool +isNull (ConstructedAtom "SQLNull" (ConstructedAtomType "SQLNullable" _) []) = True +isNull _ = False + +sqlIntegerBinaryFunction :: AtomType -> (Integer -> Integer -> Atom) -> [Atom] -> Either AtomFunctionError Atom +sqlIntegerBinaryFunction expectedAtomType op [a,b] + | isNullOrType IntegerAtomType a && isNullOrType IntegerAtomType b = + case (a,b) of + (IntegerAtom valA, IntegerAtom valB) -> do + let res = op valA valB + pure (nullAtom expectedAtomType (Just res)) + (a',b') | isNull a' || isNull b' -> pure (nullAtom expectedAtomType Nothing) + _other -> Left AtomFunctionTypeMismatchError +sqlIntegerBinaryFunction _ _ _ = Left AtomFunctionTypeMismatchError + diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index 30650b02..c3b993f2 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -50,6 +50,8 @@ import Control.Exception import GHC.Paths #endif +import Debug.Trace + data DatabaseContextExprDetails = CountUpdatedTuples databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc @@ -878,7 +880,7 @@ evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName' arguments tid) = do lift $ except (atomTypeVerify expType actType)) zippedArgs evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments case evalAtomFunction func evaldArgs of - Left err -> throwError (AtomFunctionUserError err) + Left err -> traceShow ("evalGraphrefAtomExpr"::String, funcName', arguments) $ throwError (AtomFunctionUserError err) Right result -> do --validate that the result matches the expected type _ <- lift $ except (atomTypeVerify (last (funcType func)) (atomTypeForAtom result)) diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 24b56db5..b13a364c 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -51,28 +51,28 @@ testSelect = TestCase $ do (tgraph,transId) <- freshTransactionGraph sqlDBContext (sess, conn) <- dateExamplesConnection emptyNotificationCallback - let readTests = [{- + let readTests = [ -- simple relvar ("SELECT * FROM s", "(s)", "(s)"), -- simple projection ("SELECT city FROM s", "(s{city})", "(s{city})"), -- restriction ("SELECT city FROM s where status=20", - "((s where status=20){city})", + "((s where sql_coalesce_bool(sql_equals(@status,20))){city})", "((s where status=20){city})" ), -- restriction with asterisk and qualified name ("SELECT * FROM s WHERE \"s\".\"status\"=20", - "(s where status=20)", + "(s where sql_coalesce_bool(sql_equals(@status,20)))", "(s where status=20)"), -- join via where clause ("SELECT city FROM s, sp where \"s\".\"s#\" = \"sp\".\"s#\"", - "((((s rename {s# as `s.s#`}) join sp) where `s.s#` = @s#){city})", + "((((s rename {s# as `s.s#`}) join sp) where sql_coalesce_bool(sql_equals(@`s.s#`, @s#))){city})", "(s{city} where city=\"London\" or city=\"Paris\")" ), -- restriction ("SELECT status,city FROM s where status>20", - "((s where gt(@status,20)){status,city})", + "((s where sql_coalesce_bool(sql_gt(@status,20))){status,city})", "((s where s#=\"S3\" or s#=\"S5\"){status,city})"), -- extension mixed with projection ("SELECT city,status,10 FROM s", @@ -113,7 +113,7 @@ testSelect = TestCase $ do -- unaliased join using ("SELECT * FROM sp INNER JOIN sp AS sp2 USING (\"s#\")", "(with (sp2 as sp) ((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join (sp2 rename {p# as `sp2.p#`, qty as `sp2.qty`})))", - "(with (sp2 as sp) ((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join (sp2 rename {p# as `sp2.p#`, qty as `sp2.qty`})))"),-} + "(with (sp2 as sp) ((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join (sp2 rename {p# as `sp2.p#`, qty as `sp2.qty`})))"), -- unaliased join ("SELECT * FROM sp JOIN s ON s.s# = sp.s#", "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_equals(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})", @@ -121,20 +121,20 @@ testSelect = TestCase $ do ), -- aliased join on ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#", - "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})", - "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=eq(@`s2.s#`,@`sp2.s#`)}) where join_1=True) {all but join_1})"), + "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=sql_coalesce_bool(sql_equals(@`s2.s#`,@`sp2.s#`))}) where join_1=True) {all but join_1})", + "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=sql_coalesce_bool(sql_equals(@`s2.s#`,@`sp2.s#`))}) where join_1=True) {all but join_1})"), -- formula extension ("SELECT status+10 FROM s", - "((s : {attr_1:=add(@status,10)}) { attr_1 })", - "((s : {attr_1:=add(@status,10)}) { attr_1 })"), + "((s : {attr_1:=sql_add(@status,10)}) { attr_1 })", + "((s : {attr_1:=sql_add(@status,10)}) { attr_1 })"), -- extension and formula ("SELECT status+10,city FROM s", - "((s : {attr_1:=add(@status,10)}) {city,attr_1})", - "((s : {attr_1:=add(@status,10)}) {city,attr_1})"), + "((s : {attr_1:=sql_add(@status,10)}) {city,attr_1})", + "((s : {attr_1:=sql_add(@status,10)}) {city,attr_1})"), -- complex join condition ("SELECT * FROM sp JOIN s ON s.s# = sp.s# AND s.s# = sp.s#", - "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_and(sql_equals(@`s.s#`,@`sp.s#`),eq(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})", - "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=and(eq(@`s.s#`,@`sp.s#`),eq(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})"), + "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_and(sql_equals(@`s.s#`,@`sp.s#`),sql_equals(@`s.s#`,@`sp.s#`)))}) where join_1=True) {all but join_1})", + "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_and(sql_equals(@`s.s#`,@`sp.s#`),sql_equals(@`s.s#`,@`sp.s#`)))}) where join_1=True) {all but join_1})"), -- TABLE ("TABLE s", "(s)", @@ -189,32 +189,32 @@ testSelect = TestCase $ do ), -- SELECT with no table expression ("SELECT 1,2,3", - "((relation{}{}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})", - "relation{tuple{attr_1 1, attr_2 2, attr_3 3}}" + "((relation{}{tuple{}}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})", + "(relation{tuple{attr_1 1, attr_2 2, attr_3 3}})" ), -- where exists -- complication: we need to add attribute renamers due to the subselect ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s\".\"s#\"=\"sp\".\"s#\")", - "(s where (((sp rename {s# as `sp.s#`}) where `s#`= @`sp.s#`){}))", - "s where not (s#=\"S5\")" + "(s where (((sp rename {s# as `sp.s#`}) where sql_coalesce_bool(sql_equals(@`s#`, @`sp.s#`))){}))", + "(s where not (s#=\"S5\"))" ), -- basic projection NULL ("SELECT NULL", - "((relation{}{}:{attr_1:=SQLNull}){attr_1})", + "((relation{}{tuple{}}:{attr_1:=SQLNull}){attr_1})", "((true:{attr_1:=SQLNull}){attr_1})" ), -- restriction NULL ("SELECT * FROM s WHERE s# IS NULL", - "(s where sql_isnull(@s#))", - "(s)"), - ("SELECT * FROM snull WHERE status IS NULL", - "(snull where sql_isnull(@status))", - "(snull where s#=\"S1\")"), + "(s where sql_coalesce_bool(sql_isnull(@s#)))", + "(s where false)"), + ("SELECT * FROM snull WHERE city IS NULL", + "(snull where sql_coalesce_bool(sql_isnull(@city)))", + "(snull where s#=\"S2\")"), ("SELECT NULL AND FALSE", - "((relation{}{}:{attr_1:=sql_and(SQLNull,False)}){attr_1})", + "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNull,False)}){attr_1})", "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust False}})"), ("SELECT NULL AND TRUE", - "((relation{}{}:{attr_1:=sql_and(SQLNull,True)}){attr_1})", + "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNull,True)}){attr_1})", "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})") ] gfEnv = GraphRefRelationalExprEnv { @@ -288,6 +288,7 @@ eitherFail (Right _) = pure () addNullTable :: DatabaseContextExpr addNullTable = Assign "snull" (ExistingRelation s_nullRelVar) +-- snull := relation{s# Text, sname Text, status Integer, city SQLNullable Text}{tuple{s# "S1", sname "Smith", status 20, city SQLNull}} s_nullRelVar :: Relation s_nullRelVar = case mkRelationFromList attrs atomMatrix of From f72de279a5e136b6a435d12964f85b0ee89fdcc9 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 4 Mar 2024 00:08:14 -0500 Subject: [PATCH 058/170] refactor SQL integer binary functions --- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 36 +++++++++++++----------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index a20a14c8..7dd282ab 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -50,24 +50,10 @@ nullAtomFunctions = HS.fromList [ TypeVariableType "b", nullAtomType IntegerAtomType], funcBody = FunctionBuiltInBody (sqlIntegerBinaryFunction IntegerAtomType (\a b -> IntegerAtom (a + b))) - }, - Function { - funcName = "sql_gt", - funcType = [TypeVariableType "a", - TypeVariableType "b", - nullAtomType BoolAtomType], - funcBody = FunctionBuiltInBody (sqlIntegerBinaryFunction BoolAtomType (\a b -> BoolAtom (a > b))) - }, - Function { - funcName = "sql_gte", - funcType = [TypeVariableType "a", - TypeVariableType "b", - nullAtomType IntegerAtomType], - funcBody = FunctionBuiltInBody (sqlIntegerBinaryFunction BoolAtomType (\a b -> BoolAtom (a >= b))) } - - ] + ] <> sqlBooleanIntegerFunctions where + sqlNull typ = ConstructedAtom "SQLNull" typ [] sqlNullable val typ = ConstructedAtom "SQLJust" (nullAtomType typ) [val] nullEq :: AtomFunctionBodyType @@ -77,6 +63,24 @@ nullAtomFunctions = HS.fromList [ nullEq [a,b] | atomTypeForAtom a == atomTypeForAtom b = pure (sqlNullable (BoolAtom (a == b)) BoolAtomType) nullEq _other = Left AtomFunctionTypeMismatchError +sqlBooleanIntegerFunctions :: HS.HashSet AtomFunction +sqlBooleanIntegerFunctions = HS.fromList $ + map (\(sql_func, op) -> + Function { + funcName = sql_func, + funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType], + funcBody = FunctionBuiltInBody (sqlIntegerBinaryBoolean op) + }) ops + where + sqlIntegerBinaryBoolean op = + sqlIntegerBinaryFunction BoolAtomType (\a b -> BoolAtom (a `op` b)) + ops = [("sql_gt", (>)), + ("sql_lt", (<)), + ("sql_gte", (>=)), + ("sql_lte", (<=)) + ] + + coalesceBool :: [Atom] -> Either AtomFunctionError Atom coalesceBool [arg] = case sqlBool arg of Nothing -> pure (BoolAtom False) From e03fa4f117057ee5917e60ac228fcfda649960c9 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 6 Mar 2024 22:33:08 -0500 Subject: [PATCH 059/170] refactor interpreter modules to increase code sharing between sqlegacy and tutd --- project-m36.cabal | 67 +++++++- src/bin/ProjectM36/Cli.hs | 143 ++++++++++++++++++ src/bin/ProjectM36/Interpreter.hs | 28 ++++ src/bin/SQL/Interpreter.hs | 60 ++++++++ src/bin/SQL/Interpreter/Base.hs | 5 +- src/bin/SQL/Interpreter/Select.hs | 1 + src/bin/SQL/Interpreter/sqlegacy.hs | 55 +++++++ src/bin/TutorialD/Interpreter.hs | 47 +----- src/bin/TutorialD/Interpreter/Base.hs | 29 +--- .../Interpreter/DatabaseContextExpr.hs | 1 + .../Interpreter/DatabaseContextIOOperator.hs | 1 + src/bin/TutorialD/Interpreter/Export/CSV.hs | 3 +- .../Interpreter/Import/BasicExamples.hs | 1 + src/bin/TutorialD/Interpreter/Import/CSV.hs | 1 + .../TutorialD/Interpreter/Import/TutorialD.hs | 1 + .../Interpreter/InformationOperator.hs | 1 + .../Interpreter/RODatabaseContextOperator.hs | 5 +- .../TutorialD/Interpreter/RelationalExpr.hs | 1 + .../TutorialD/Interpreter/SchemaOperator.hs | 1 + .../TransGraphRelationalOperator.hs | 3 +- .../Interpreter/TransactionGraphOperator.hs | 1 + src/bin/TutorialD/Interpreter/Types.hs | 1 + src/bin/TutorialD/tutd.hs | 103 +------------ 23 files changed, 381 insertions(+), 178 deletions(-) create mode 100644 src/bin/ProjectM36/Cli.hs create mode 100644 src/bin/ProjectM36/Interpreter.hs create mode 100644 src/bin/SQL/Interpreter.hs create mode 100644 src/bin/SQL/Interpreter/sqlegacy.hs diff --git a/project-m36.cabal b/project-m36.cabal index 3521c1b2..ba1f4d4e 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -216,10 +216,9 @@ Executable tutd TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, - SQL.Interpreter.Base, - SQL.Interpreter.Select, - SQL.Interpreter.Convert - TutorialD.Printer + TutorialD.Printer, + ProjectM36.Cli, + ProjectM36.Interpreter main-is: TutorialD/tutd.hs CC-Options: -fPIC if os(windows) @@ -232,6 +231,66 @@ Executable tutd Default-Language: Haskell2010 Default-Extensions: OverloadedStrings +Executable sqlegacy + if flag(haskell-scripting) + Build-Depends: ghc >= 9.0 && < 9.5 + Build-Depends: base, + ghc-paths, + project-m36, + containers, + unordered-containers, + hashable, + transformers, + semigroups, + mtl, + uuid, + deepseq-generics, + MonadRandom, MonadRandom, + vector, + text, + time, + bytestring, + stm, + deepseq, + data-interval, + parallel, + cassava, + gnuplot, + directory, + filepath, + temporary, + megaparsec >= 5.2.0 && < 10, + haskeline, + random, MonadRandom, + base64-bytestring, + optparse-applicative, + attoparsec, + stm-containers >= 1.0.0, + list-t, + parser-combinators, + curryer-rpc, + prettyprinter, + cryptohash-sha256, + --due to decode signature change + base16-bytestring >= 1.0.0.0, + http-conduit, + modern-uri, + http-types, + recursion-schemes, + Other-Modules: SQL.Interpreter.Base, + SQL.Interpreter.Convert, + SQL.Interpreter.Select + Main-Is: ./SQL/Interpreter/sqlegacy.hs + if os(windows) + GHC-Options: -Wall -threaded -rtsopts + else + GHC-Options: -Wall -threaded -rtsopts -rdynamic + if flag(profiler) + GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall + Hs-Source-Dirs: ./src/bin + Default-Language: Haskell2010 + Default-Extensions: OverloadedStrings + Executable project-m36-server if flag(haskell-scripting) Build-Depends: ghc >= 9.0 && < 9.5 diff --git a/src/bin/ProjectM36/Cli.hs b/src/bin/ProjectM36/Cli.hs new file mode 100644 index 00000000..2ec8c234 --- /dev/null +++ b/src/bin/ProjectM36/Cli.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE LambdaCase, DeriveGeneric #-} +-- functions common to both tutd and sqlegacy command line interfaces +module ProjectM36.Cli where +import qualified ProjectM36.Client as C +import qualified Data.Text as T +import ProjectM36.Base +import System.Console.Haskeline +import Control.Exception +import System.IO +import ProjectM36.Relation.Show.Term -- probably want to display dataframes instead +import ProjectM36.Error +import Options.Applicative +import ProjectM36.Server.ParseArgs +import ProjectM36.Server (checkFSType, checkFSErrorMsg) +import Data.Maybe (fromMaybe) +import GHC.IO.Encoding +import Control.Monad (when) +import System.Exit +import Text.Megaparsec.Error +import Data.Void (Void) +import ProjectM36.Interpreter hiding (Parser) + +type GhcPkgPath = String +type TutorialDExec = String +type CheckFS = Bool + +type DirectExecute = String +type ParserError = ParseErrorBundle T.Text Void + +data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe DirectExecute) [GhcPkgPath] CheckFS | + RemoteInterpreterConfig C.Hostname C.Port C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS + +outputNotificationCallback :: C.NotificationCallback +outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot + +prettyEvaluatedNotification :: C.EvaluatedNotification -> String +prettyEvaluatedNotification eNotif = let eRelShow eRel = case eRel of + Left err -> show err + Right reportRel -> T.unpack (showRelation reportRel) in + eRelShow (C.reportOldRelation eNotif) <> "\n" <> eRelShow (C.reportNewRelation eNotif) + +type ReprLoopEvaluator = C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () +type MakePrompt = Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType +type HistoryFilePath = FilePath + +reprLoop :: InterpreterConfig -> HistoryFilePath -> ReprLoopEvaluator -> MakePrompt -> C.SessionId -> C.Connection -> IO () +reprLoop config historyFilePath reprLoopEvaluator promptText sessionId conn = do + let settings = defaultSettings {historyFile = Just historyFilePath} -- (homeDirectory ++ "/.tutd_history")} + eHeadName <- C.headName sessionId conn + eSchemaName <- C.currentSchemaName sessionId conn + let prompt = promptText eHeadName eSchemaName + catchInterrupt = handleJust (\case + UserInterrupt -> Just Nothing + _ -> Nothing) (\_ -> do + hPutStrLn stderr "Statement cancelled. Use \":quit\" to exit." + pure (Just "")) + maybeLine <- catchInterrupt $ runInputT settings $ getInputLine (T.unpack prompt) + case maybeLine of + Nothing -> return () + Just line -> do + reprLoopEvaluator sessionId conn (Just (T.length prompt)) (T.pack line) + reprLoop config historyFilePath reprLoopEvaluator promptText sessionId conn + +parseArgs :: Parser InterpreterConfig +parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseDirectExecute <*> many parseGhcPkgPath <*> parseCheckFS <|> + RemoteInterpreterConfig <$> parseHostname "127.0.0.1" <*> parsePort C.defaultServerPort <*> parseDatabaseName <*> parseHeadName <*> parseDirectExecute <*> parseCheckFS + +parseHeadName :: Parser HeadName +parseHeadName = option auto (long "head" <> + help "Start session at head name." <> + metavar "GRAPH HEAD NAME" <> + value "master" + ) + +parseDirectExecute :: Parser (Maybe DirectExecute) +parseDirectExecute = optional $ strOption (long "exec-tutd" <> + short 'e' <> + metavar "TUTORIALD" <> + help "Execute TutorialD expression and exit" + ) + +type PrintWelcome = IO () +type ExecUserInput = C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () + +mainLoop :: IO () -> HistoryFilePath -> ReprLoopEvaluator -> MakePrompt -> ExecUserInput -> DatabaseContext -> IO () +mainLoop printWelcome historyFilePath reprLoopEvaluator promptText execUserInput defaultDBContext = do + setLocaleIfNecessary + interpreterConfig <- execParser opts + let connInfo = connectionInfoForConfig interpreterConfig defaultDBContext + fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig)) + if not fscheck then + errDie checkFSErrorMsg + else do + dbconn <- C.connectProjectM36 connInfo + case dbconn of + Left err -> + errDie ("Failed to create database connection: " ++ show err) + Right conn -> do + let connHeadName = headNameForConfig interpreterConfig + eSessionId <- C.createSessionAtHead conn connHeadName + case eSessionId of + Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err) + Right sessionId -> + case directExecForConfig interpreterConfig of + Nothing -> do + printWelcome + _ <- reprLoop interpreterConfig historyFilePath reprLoopEvaluator promptText sessionId conn + pure () + Just execStr -> + execUserInput sessionId conn Nothing (T.pack execStr) + +-- | If the locale is set to ASCII, upgrade it to UTF-8 because tutd outputs UTF-8-encoded attributes. This is especially important in light docker images where the locale data may be missing. +setLocaleIfNecessary :: IO () +setLocaleIfNecessary = do + l <- getLocaleEncoding + when (textEncodingName l == "ASCII") (setLocaleEncoding utf8) + +opts :: ParserInfo InterpreterConfig +opts = info (parseArgs <**> helpOption) idm + +connectionInfoForConfig :: InterpreterConfig -> DatabaseContext -> C.ConnectionInfo +connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) defaultDBContext = C.InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths defaultDBContext +connectionInfoForConfig (RemoteInterpreterConfig remoteHost remotePort remoteDBName _ _ _) _ = C.RemoteConnectionInfo remoteDBName remoteHost (show remotePort) outputNotificationCallback + +headNameForConfig :: InterpreterConfig -> HeadName +headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn +headNameForConfig (RemoteInterpreterConfig _ _ _ headn _ _) = headn + +directExecForConfig :: InterpreterConfig -> Maybe String +directExecForConfig (LocalInterpreterConfig _ _ t _ _) = t +directExecForConfig (RemoteInterpreterConfig _ _ _ _ t _) = t + +checkFSForConfig :: InterpreterConfig -> Bool +checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c +checkFSForConfig (RemoteInterpreterConfig _ _ _ _ _ c) = c + +persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy +persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat +persistenceStrategyForConfig RemoteInterpreterConfig{} = Nothing + +errDie :: String -> IO () +errDie err = hPutStrLn stderr err >> exitFailure + diff --git a/src/bin/ProjectM36/Interpreter.hs b/src/bin/ProjectM36/Interpreter.hs new file mode 100644 index 00000000..5b26bfd7 --- /dev/null +++ b/src/bin/ProjectM36/Interpreter.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} +-- functions common to both SQL and TutorialD interpreters +module ProjectM36.Interpreter where +import ProjectM36.Base +import ProjectM36.DataFrame +import Text.Megaparsec +import Data.Void +import Data.Text +import GHC.Generics + +type Parser = Parsec Void Text +type ParserError = ParseErrorBundle Text Void +type PromptLength = Int + +data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq) + +data ConsoleResult = QuitResult | + DisplayResult StringType | + DisplayIOResult (IO ()) | + DisplayRelationResult Relation | + DisplayDataFrameResult DataFrame | + DisplayErrorResult StringType | + DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text + QuietSuccessResult + deriving (Generic) + +type InteractiveConsole = Bool + diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs new file mode 100644 index 00000000..01e7296c --- /dev/null +++ b/src/bin/SQL/Interpreter.hs @@ -0,0 +1,60 @@ +module SQL.Interpreter where +import ProjectM36.Base +import ProjectM36.Interpreter +import SQL.Interpreter.Base +import SQL.Interpreter.Select +import SQL.Interpreter.Convert +import qualified Data.Text as T +import qualified ProjectM36.Client as C +import Text.Megaparsec +import Text.Megaparsec.Error +import Data.Void +import Text.Megaparsec.Char +import Data.Text (Text) + +data ImportBasicExampleOperator = ImportBasicExampleOperator T.Text + deriving (Show) + +data SQLCommand = RODatabaseContextOp Select | -- SELECT + DatabaseContextExprOp DatabaseContextExpr | -- UPDATE, DELETE, INSERT + ImportBasicExampleOp ImportBasicExampleOperator -- IMPORT EXAMPLE cjdate + deriving (Show) + +parseSQLUserInput :: T.Text -> Either ParserError SQLCommand +parseSQLUserInput = parse parseRODatabaseContextOp "" -- <|> parseDatabaseContextExprOp <|> parseImportBasicExampleOp) + +parseRODatabaseContextOp :: Parser SQLCommand +parseRODatabaseContextOp = RODatabaseContextOp <$> queryExprP + +parseDatabaseContextExprOp :: Parser SQLCommand +parseDatabaseContextExprOp = undefined + +evalSQLInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> SQLCommand -> IO ConsoleResult +evalSQLInteractive sesssionId conn safeFlag interactiveConsole command = + case command of + RODatabaseContextOp sel -> do + --get relvars to build conversion context + eAllRelVars <- C.relationVariablesAsRelation sessionId conn + case eAllRelVars of + Left err -> pure (DisplayRelationalErrorResult err) + Right allRelVars -> + +-- relIn has attributes "attributes"::relation {attribute::Text,type::Text} and "name"::Text +mkConversionTableContextFromRelation :: Relation -> TableContext +mkConversionTableContextFromRelation relIn = + TableContext $ relFold folder mempty relIn + where + folder tup acc = + case atomForAttributeName "name" tup of + Left err -> pure acc + Right rvname -> + case atomForAttributeName "attributes" tup of + Left err -> pure acc + Right (RelationAtom attrsRel) -> + let attrs = attributesFromList $ relFold attrsFolder [] attrsRel + M.insert name (RelationVariable name (), attrs, mempty) + attrsFolder tup acc = + case atomForAttributeName "attribute" tup of + Left err -> pure acc + Right (Re + diff --git a/src/bin/SQL/Interpreter/Base.hs b/src/bin/SQL/Interpreter/Base.hs index 867b62a1..f0883527 100644 --- a/src/bin/SQL/Interpreter/Base.hs +++ b/src/bin/SQL/Interpreter/Base.hs @@ -1,13 +1,10 @@ module SQL.Interpreter.Base where +import ProjectM36.Interpreter import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as Lex -import Data.Void (Void) import Data.Text as T (Text, singleton, pack, splitOn, toLower) - -type Parser = Parsec Void Text - -- consumes only horizontal spaces spaceConsumer :: Parser () spaceConsumer = Lex.space space1 (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}") diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 903df9d0..5acf5aed 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, DeriveTraversable, GeneralizedNewtypeDeriving #-} module SQL.Interpreter.Select where +import ProjectM36.Interpreter import Text.Megaparsec import Text.Megaparsec.Char import Control.Monad.Combinators.Expr as E diff --git a/src/bin/SQL/Interpreter/sqlegacy.hs b/src/bin/SQL/Interpreter/sqlegacy.hs new file mode 100644 index 00000000..a7ce7004 --- /dev/null +++ b/src/bin/SQL/Interpreter/sqlegacy.hs @@ -0,0 +1,55 @@ +-- the sqlegacy SQL interpreter wrap +{-# LANGUAGE CPP #-} +import SQL.Interpreter.Convert +import ProjectM36.Base +import ProjectM36.Cli +import SQL.Interpreter +import ProjectM36.SQLDatabaseContext +import ProjectM36.Error +import System.Directory +import System.FilePath +import qualified ProjectM36.Client as C +import qualified Data.Text as T +import Data.Either (fromRight) +import Control.Exception (catchJust) +import ProjectM36.Interpreter + + +#if !defined(VERSION_project_m36) +# warning Failed to discover proper version from cabal_macros.h +# define VERSION_project_m36 "" +#endif + +main :: IO () +main = do + homeDir <- getHomeDirectory + let historyPath = homeDir ".sqlegacy_history" + mainLoop printWelcome historyPath sqlReprLoop promptText sqlReprLoop sqlDatabaseContext + +printWelcome :: IO () +printWelcome = do + putStrLn ("Project:M36 SQLegacy Interpreter " ++ VERSION_project_m36) + putStrLn "SQL does not support the complete relational algebra. To access the complete relational algebra, use the bundled \"tutd\" interpreter." + putStrLn "Type \"help\" for more information." + +sqlReprLoop :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () +sqlReprLoop sessionId conn mPromptLength userInput = do + case parseSQLUserInput userInput of + Left err -> + displayResult (DisplayParseErrorResult mPromptLength err) + Right parsed -> + catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do + evald <- evalSQLInteractive sessionId conn UnsafeEvaluation True parsed + displayResult evald) + (\_ -> displayResult (DisplayErrorResult "Request timed out.")) + + +promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType +promptText eHeadName eSchemaName = "SQLegacy (" <> transInfo <> "): " + where + transInfo = fromRight "" eHeadName <> "/" <> fromRight "" eSchemaName + + +displayResult :: ConsoleResult -> IO () +displayResult = undefined + diff --git a/src/bin/TutorialD/Interpreter.hs b/src/bin/TutorialD/Interpreter.hs index 6e87669d..ee0c5d77 100644 --- a/src/bin/TutorialD/Interpreter.hs +++ b/src/bin/TutorialD/Interpreter.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs, LambdaCase, CPP #-} module TutorialD.Interpreter where +import ProjectM36.Interpreter import TutorialD.Interpreter.Base import TutorialD.Interpreter.RODatabaseContextOperator import TutorialD.Interpreter.DatabaseContextExpr @@ -19,15 +20,12 @@ import TutorialD.Interpreter.Export.Base import ProjectM36.Base import ProjectM36.Error -import ProjectM36.Relation.Show.Term import ProjectM36.TransactionGraph import qualified ProjectM36.Client as C import ProjectM36.Relation (attributes) import System.Console.Haskeline -import System.Directory (getHomeDirectory) import qualified Data.Text as T -import System.IO (hPutStrLn, stderr) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif @@ -87,15 +85,12 @@ parseTutorialD = parse interpreterParserP "" safeParseTutorialD :: T.Text -> Either ParserError ParsedOperation safeParseTutorialD = parse safeInterpreterParserP "" -data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq) -type InteractiveConsole = Bool - -evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO TutorialDOperatorResult +evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO ConsoleResult evalTutorialD sessionId conn safe = evalTutorialDInteractive sessionId conn safe False --execute the operation and display result -evalTutorialDInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> ParsedOperation -> IO TutorialDOperatorResult +evalTutorialDInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> ParsedOperation -> IO ConsoleResult evalTutorialDInteractive sessionId conn safe interactive expr = case expr of --this does not pass through the ProjectM36.Client library because the operations --are specific to the interpreter, though some operations may be of general use in the future @@ -214,7 +209,7 @@ evalTutorialDInteractive sessionId conn safe interactive expr = case expr of where needsSafe = safe == SafeEvaluation unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited." - barf :: RelationalError -> IO TutorialDOperatorResult + barf :: RelationalError -> IO ConsoleResult barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr)) barf (ParseError err) = pure (DisplayErrorResult err) barf err = return $ DisplayErrorResult (T.pack (show err)) @@ -224,40 +219,7 @@ evalTutorialDInteractive sessionId conn safe interactive expr = case expr of Left err -> barf err Right () -> return QuietSuccessResult -type GhcPkgPath = String -type TutorialDExec = String -type CheckFS = Bool - -data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] CheckFS | - RemoteInterpreterConfig C.Hostname C.Port C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS - -outputNotificationCallback :: C.NotificationCallback -outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot -prettyEvaluatedNotification :: C.EvaluatedNotification -> String -prettyEvaluatedNotification eNotif = let eRelShow eRel = case eRel of - Left err -> show err - Right reportRel -> T.unpack (showRelation reportRel) in - eRelShow (C.reportOldRelation eNotif) <> "\n" <> eRelShow (C.reportNewRelation eNotif) - -reprLoop :: InterpreterConfig -> C.SessionId -> C.Connection -> IO () -reprLoop config sessionId conn = do - homeDirectory <- getHomeDirectory - let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")} - eHeadName <- C.headName sessionId conn - eSchemaName <- C.currentSchemaName sessionId conn - let prompt = promptText eHeadName eSchemaName - catchInterrupt = handleJust (\case - UserInterrupt -> Just Nothing - _ -> Nothing) (\_ -> do - hPutStrLn stderr "Statement cancelled. Use \":quit\" to exit tutd." - pure (Just "")) - maybeLine <- catchInterrupt $ runInputT settings $ getInputLine (T.unpack prompt) - case maybeLine of - Nothing -> return () - Just line -> do - runTutorialD sessionId conn (Just (T.length prompt)) (T.pack line) - reprLoop config sessionId conn runTutorialD :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () @@ -270,3 +232,4 @@ runTutorialD sessionId conn mPromptLength tutd = evald <- evalTutorialDInteractive sessionId conn UnsafeEvaluation True parsed displayOpResult evald) (\_ -> displayOpResult (DisplayErrorResult "Request timed out.")) + diff --git a/src/bin/TutorialD/Interpreter/Base.hs b/src/bin/TutorialD/Interpreter/Base.hs index c537148d..4d3a11e5 100644 --- a/src/bin/TutorialD/Interpreter/Base.hs +++ b/src/bin/TutorialD/Interpreter/Base.hs @@ -15,12 +15,12 @@ import ProjectM36.AtomType import ProjectM36.Attribute as A import ProjectM36.Relation import ProjectM36.DataFrame +import ProjectM36.Interpreter #if MIN_VERSION_megaparsec(6,0,0) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as Lex import Text.Megaparsec -import Data.Void import Control.Applicative hiding (many, some) #else import Text.Megaparsec.Text @@ -34,7 +34,6 @@ import qualified Data.List as L import qualified Data.Text.IO as TIO import System.IO import ProjectM36.Relation.Show.Term -import GHC.Generics #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif @@ -50,7 +49,7 @@ anySingle :: Parsec Void Text (Token Text) anySingle = anyChar #endif -displayOpResult :: TutorialDOperatorResult -> IO () +displayOpResult :: ConsoleResult -> IO () displayOpResult QuitResult = return () displayOpResult (DisplayResult out) = TIO.putStrLn out displayOpResult (DisplayIOResult ioout) = ioout @@ -74,12 +73,7 @@ displayOpResult (DisplayParseErrorResult mPromptLength err) = do TIO.putStr ("ERR:" <> errString) displayOpResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame) -#if MIN_VERSION_megaparsec(6,0,0) -type Parser = Parsec Void Text type ParseStr = Text -#else -type ParseStr = String -#endif -- consumes only horizontal spaces spaceConsumer :: Parser () @@ -184,25 +178,6 @@ showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showA showAttribute (Attribute name atomType') = name <> " " <> prettyAtomType atomType' attrsL = A.toList attrs -type PromptLength = Int - -#if MIN_VERSION_megaparsec(7,0,0) -type ParserError = ParseErrorBundle T.Text Void -#elif MIN_VERSION_megaparsec(6,0,0) -type ParserError = ParseError Char Void -#else -type ParserError = ParseError Char Dec -#endif - -data TutorialDOperatorResult = QuitResult | - DisplayResult StringType | - DisplayIOResult (IO ()) | - DisplayRelationResult Relation | - DisplayDataFrameResult DataFrame | - DisplayErrorResult StringType | - DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text - QuietSuccessResult - deriving (Generic) type TransactionGraphWasUpdated = Bool diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs index 429437fd..61dbca89 100644 --- a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module TutorialD.Interpreter.DatabaseContextExpr where import ProjectM36.Base +import ProjectM36.Interpreter import TutorialD.Interpreter.Base import qualified Data.Text as T import TutorialD.Interpreter.RelationalExpr diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs index 4a3b4469..053d0992 100644 --- a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs @@ -1,6 +1,7 @@ --compiling the script requires the IO monad because it must load modules from the filesystem, so we create the function and generate the requisite DatabaseExpr here. module TutorialD.Interpreter.DatabaseContextIOOperator where import ProjectM36.Base +import ProjectM36.Interpreter import TutorialD.Interpreter.Base import TutorialD.Interpreter.Types import Data.Text diff --git a/src/bin/TutorialD/Interpreter/Export/CSV.hs b/src/bin/TutorialD/Interpreter/Export/CSV.hs index 26fddd18..c751aa1b 100644 --- a/src/bin/TutorialD/Interpreter/Export/CSV.hs +++ b/src/bin/TutorialD/Interpreter/Export/CSV.hs @@ -1,5 +1,6 @@ module TutorialD.Interpreter.Export.CSV where import ProjectM36.Relation.Show.CSV +import ProjectM36.Interpreter import TutorialD.Interpreter.Export.Base import TutorialD.Interpreter.RelationalExpr import TutorialD.Interpreter.Base hiding (try) @@ -24,4 +25,4 @@ exportRelationCSV (RelVarDataExportOperator _ pathOut _) rel = writeResult <- try (BS.writeFile pathOut csvData) :: IO (Either IOError ()) case writeResult of Left err -> return $ Just (ExportError $ T.pack (show err)) - Right _ -> return Nothing \ No newline at end of file + Right _ -> return Nothing diff --git a/src/bin/TutorialD/Interpreter/Import/BasicExamples.hs b/src/bin/TutorialD/Interpreter/Import/BasicExamples.hs index 4fb6a330..7fd6340a 100644 --- a/src/bin/TutorialD/Interpreter/Import/BasicExamples.hs +++ b/src/bin/TutorialD/Interpreter/Import/BasicExamples.hs @@ -3,6 +3,7 @@ module TutorialD.Interpreter.Import.BasicExamples where import ProjectM36.DateExamples import ProjectM36.Base +import ProjectM36.Interpreter import ProjectM36.DatabaseContext import TutorialD.Interpreter.Base diff --git a/src/bin/TutorialD/Interpreter/Import/CSV.hs b/src/bin/TutorialD/Interpreter/Import/CSV.hs index 0943bed8..d56a1250 100644 --- a/src/bin/TutorialD/Interpreter/Import/CSV.hs +++ b/src/bin/TutorialD/Interpreter/Import/CSV.hs @@ -2,6 +2,7 @@ module TutorialD.Interpreter.Import.CSV where import TutorialD.Interpreter.Import.Base import ProjectM36.Base +import ProjectM36.Interpreter import ProjectM36.Error import ProjectM36.Relation.Parse.CSV hiding (quotedString) import qualified Data.ByteString.Lazy as BS diff --git a/src/bin/TutorialD/Interpreter/Import/TutorialD.hs b/src/bin/TutorialD/Interpreter/Import/TutorialD.hs index f4f65db6..712073c9 100644 --- a/src/bin/TutorialD/Interpreter/Import/TutorialD.hs +++ b/src/bin/TutorialD/Interpreter/Import/TutorialD.hs @@ -1,5 +1,6 @@ module TutorialD.Interpreter.Import.TutorialD where import ProjectM36.Base +import ProjectM36.Interpreter import TutorialD.Interpreter.Import.Base import TutorialD.Interpreter.Base hiding (try) import TutorialD.Interpreter.DatabaseContextExpr diff --git a/src/bin/TutorialD/Interpreter/InformationOperator.hs b/src/bin/TutorialD/Interpreter/InformationOperator.hs index 960f9fb1..d20b5edc 100644 --- a/src/bin/TutorialD/Interpreter/InformationOperator.hs +++ b/src/bin/TutorialD/Interpreter/InformationOperator.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module TutorialD.Interpreter.InformationOperator where import Data.Text +import ProjectM36.Interpreter import Text.Megaparsec import TutorialD.Interpreter.Base -- older versions of stack fail to diff --git a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs index cd8c575d..9a1ecc6c 100644 --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -2,6 +2,7 @@ module TutorialD.Interpreter.RODatabaseContextOperator where import ProjectM36.Base import ProjectM36.Relation +import ProjectM36.Interpreter import qualified ProjectM36.DataFrame as DF import ProjectM36.Error import ProjectM36.Tuple @@ -96,7 +97,7 @@ roDatabaseContextOperatorP = typeP <|> quitP --logically, these read-only operations could happen purely, but not if a remote call is required -evalRODatabaseContextOp :: C.SessionId -> C.Connection -> RODatabaseContextOperator -> IO TutorialDOperatorResult +evalRODatabaseContextOp :: C.SessionId -> C.Connection -> RODatabaseContextOperator -> IO ConsoleResult evalRODatabaseContextOp sessionId conn (ShowRelationType expr) = do res <- C.typeForRelationalExpr sessionId conn expr case res of @@ -194,7 +195,7 @@ evalRODatabaseContextOp sessionId conn ShowRegisteredQueries = do evalRODatabaseContextOp _ _ Quit = pure QuitResult -interpretRODatabaseContextOp :: C.SessionId -> C.Connection -> T.Text -> IO TutorialDOperatorResult +interpretRODatabaseContextOp :: C.SessionId -> C.Connection -> T.Text -> IO ConsoleResult interpretRODatabaseContextOp sessionId conn tutdstring = case parse roDatabaseContextOperatorP "" tutdstring of Left err -> pure $ DisplayErrorResult (T.pack (show err)) Right parsed -> evalRODatabaseContextOp sessionId conn parsed diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs index 890a0d88..31539531 100644 --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -7,6 +7,7 @@ import Control.Monad.Combinators.Expr import Text.Megaparsec.Expr #endif import ProjectM36.Base +import ProjectM36.Interpreter import TutorialD.Interpreter.Base import TutorialD.Interpreter.Types import qualified Data.Text as T diff --git a/src/bin/TutorialD/Interpreter/SchemaOperator.hs b/src/bin/TutorialD/Interpreter/SchemaOperator.hs index e3685a25..e3177955 100644 --- a/src/bin/TutorialD/Interpreter/SchemaOperator.hs +++ b/src/bin/TutorialD/Interpreter/SchemaOperator.hs @@ -1,5 +1,6 @@ module TutorialD.Interpreter.SchemaOperator where import Text.Megaparsec +import ProjectM36.Interpreter import ProjectM36.Base import ProjectM36.IsomorphicSchema import ProjectM36.Session diff --git a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs index 075eeb99..bb4a6172 100644 --- a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs @@ -3,6 +3,7 @@ module TutorialD.Interpreter.TransGraphRelationalOperator where import ProjectM36.TransGraphRelationalExpression import ProjectM36.TransactionGraph +import ProjectM36.Interpreter import TutorialD.Interpreter.Types import qualified ProjectM36.Client as C @@ -37,7 +38,7 @@ showTransGraphRelationalOpP = do reservedOp ":showtransgraphexpr" ShowTransGraphRelation <$> relExprP -evalTransGraphRelationalOp :: C.SessionId -> C.Connection -> TransGraphRelationalOperator -> IO TutorialDOperatorResult +evalTransGraphRelationalOp :: C.SessionId -> C.Connection -> TransGraphRelationalOperator -> IO ConsoleResult evalTransGraphRelationalOp sessionId conn (ShowTransGraphRelation expr) = do res <- C.executeTransGraphRelationalExpr sessionId conn expr case res of diff --git a/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs b/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs index 7d0b387d..dafa950c 100644 --- a/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs @@ -3,6 +3,7 @@ module TutorialD.Interpreter.TransactionGraphOperator where import TutorialD.Interpreter.Base import ProjectM36.TransactionGraph hiding (autoMergeToHead) import ProjectM36.Client as C +import ProjectM36.Interpreter import ProjectM36.Base import ProjectM36.Relation (relationTrue) import Data.Functor diff --git a/src/bin/TutorialD/Interpreter/Types.hs b/src/bin/TutorialD/Interpreter/Types.hs index b7433748..7d3370e6 100644 --- a/src/bin/TutorialD/Interpreter/Types.hs +++ b/src/bin/TutorialD/Interpreter/Types.hs @@ -1,6 +1,7 @@ --parse type and data constructors module TutorialD.Interpreter.Types where import ProjectM36.Base +import ProjectM36.Interpreter import Text.Megaparsec import TutorialD.Interpreter.Base diff --git a/src/bin/TutorialD/tutd.hs b/src/bin/TutorialD/tutd.hs index 99544dae..e4cecdec 100644 --- a/src/bin/TutorialD/tutd.hs +++ b/src/bin/TutorialD/tutd.hs @@ -1,77 +1,15 @@ {-# LANGUAGE CPP #-} import TutorialD.Interpreter -import ProjectM36.Base -import ProjectM36.Client -import ProjectM36.Server.ParseArgs -import ProjectM36.Server +import ProjectM36.Cli import ProjectM36.DatabaseContext -import ProjectM36.SQLDatabaseContext -import System.IO -import GHC.IO.Encoding -import Options.Applicative -import System.Exit -import Control.Monad -#if __GLASGOW_HASKELL__ < 804 -import Data.Monoid -#endif -import Data.Maybe -import qualified Data.Text as T +import System.Directory +import System.FilePath #if !defined(VERSION_project_m36) -# warning Failed to discover proper version from cabal_macros.h +# error Failed to discover proper version from cabal_macros.h # define VERSION_project_m36 "" #endif -parseArgs :: Parser InterpreterConfig -parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> many parseGhcPkgPath <*> parseCheckFS <|> - RemoteInterpreterConfig <$> parseHostname "127.0.0.1" <*> parsePort defaultServerPort <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec <*> parseCheckFS - -parseHeadName :: Parser HeadName -parseHeadName = option auto (long "head" <> - help "Start session at head name." <> - metavar "GRAPH HEAD NAME" <> - value "master" - ) - ---just execute some tutd and exit -parseTutDExec :: Parser (Maybe TutorialDExec) -parseTutDExec = optional $ strOption (long "exec-tutd" <> - short 'e' <> - metavar "TUTORIALD" <> - help "Execute TutorialD expression and exit" - ) - -opts :: ParserInfo InterpreterConfig -opts = info (parseArgs <**> helpOption) idm - -connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo -connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths - --basicDatabaseContext - sqlDatabaseContext -- for testing sql functions ONLY! DO NOT COMMIT -connectionInfoForConfig (RemoteInterpreterConfig remoteHost remotePort remoteDBName _ _ _) = RemoteConnectionInfo remoteDBName remoteHost (show remotePort) outputNotificationCallback - -headNameForConfig :: InterpreterConfig -> HeadName -headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn -headNameForConfig (RemoteInterpreterConfig _ _ _ headn _ _) = headn - -execTutDForConfig :: InterpreterConfig -> Maybe String -execTutDForConfig (LocalInterpreterConfig _ _ t _ _) = t -execTutDForConfig (RemoteInterpreterConfig _ _ _ _ t _) = t - -checkFSForConfig :: InterpreterConfig -> Bool -checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c -checkFSForConfig (RemoteInterpreterConfig _ _ _ _ _ c) = c - -persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy -persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat -persistenceStrategyForConfig RemoteInterpreterConfig{} = Nothing - -errDie :: String -> IO () -errDie err = hPutStrLn stderr err >> exitFailure - -#ifndef VERSION_project_m36 -#error VERSION_project_m36 is not defined -#endif printWelcome :: IO () printWelcome = do putStrLn $ "Project:M36 TutorialD Interpreter " ++ VERSION_project_m36 @@ -79,36 +17,7 @@ printWelcome = do putStrLn "A full tutorial is available at:" putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown" --- | If the locale is set to ASCII, upgrade it to UTF-8 because tutd outputs UTF-8-encoded attributes. This is especially important in light docker images where the locale data may be missing. -setLocaleIfNecessary :: IO () -setLocaleIfNecessary = do - l <- getLocaleEncoding - when (textEncodingName l == "ASCII") (setLocaleEncoding utf8) - main :: IO () main = do - setLocaleIfNecessary - interpreterConfig <- execParser opts - let connInfo = connectionInfoForConfig interpreterConfig - fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig)) - if not fscheck then - errDie checkFSErrorMsg - else do - dbconn <- connectProjectM36 connInfo - case dbconn of - Left err -> - errDie ("Failed to create database connection: " ++ show err) - Right conn -> do - let connHeadName = headNameForConfig interpreterConfig - eSessionId <- createSessionAtHead conn connHeadName - case eSessionId of - Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err) - Right sessionId -> - case execTutDForConfig interpreterConfig of - Nothing -> do - printWelcome - _ <- reprLoop interpreterConfig sessionId conn - pure () - Just tutdStr -> - runTutorialD sessionId conn Nothing (T.pack tutdStr) - + homeDir <- getHomeDirectory + mainLoop printWelcome (homeDir ".tutd_history") runTutorialD promptText runTutorialD basicDatabaseContext From 218dafdf801a6b83fee79554b49873ba491eff61 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 7 Mar 2024 15:52:59 -0500 Subject: [PATCH 060/170] WIP dealing with chicken-and-egg issue- trying to figure out if SQL conversion must be part of project-m36 library or just the sqlegecy interpreter because the conversion process needs a typeF function to determine how to handle certain SQL constructs, we may need to require the SQL conversion process to occur within the project-m36 library --- project-m36.cabal | 5 ++++- src/bin/SQL/Interpreter.hs | 27 +++++++++++++++++++++------ src/bin/SQL/Interpreter/Convert.hs | 10 ++++++++++ src/bin/SQL/Interpreter/Select.hs | 3 +++ src/lib/ProjectM36/Client.hs | 30 ++++++++++++++++++++++++++++++ 5 files changed, 68 insertions(+), 7 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index ba1f4d4e..676b9fcc 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -279,7 +279,10 @@ Executable sqlegacy recursion-schemes, Other-Modules: SQL.Interpreter.Base, SQL.Interpreter.Convert, - SQL.Interpreter.Select + SQL.Interpreter.Select, + ProjectM36.Cli, + ProjectM36.Interpreter, + SQL.Interpreter Main-Is: ./SQL/Interpreter/sqlegacy.hs if os(windows) GHC-Options: -Wall -threaded -rtsopts diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs index 01e7296c..93d87c85 100644 --- a/src/bin/SQL/Interpreter.hs +++ b/src/bin/SQL/Interpreter.hs @@ -34,12 +34,19 @@ evalSQLInteractive sesssionId conn safeFlag interactiveConsole command = case command of RODatabaseContextOp sel -> do --get relvars to build conversion context - eAllRelVars <- C.relationVariablesAsRelation sessionId conn - case eAllRelVars of - Left err -> pure (DisplayRelationalErrorResult err) - Right allRelVars -> + eRelExpr <- C.convertSQL sessionId conn sel + case eRelExpr of + Left err -> pure $ DisplayRelationalErrorResult err + Right relExpr -> do + eRel <- C.executeRelationalExpr sessionId conn relExpr + case eRel of + Left err -> pure $ DisplayRelationalErrorResult err + Right rel -> pure $ DisplayRelationResult rel + --- relIn has attributes "attributes"::relation {attribute::Text,type::Text} and "name"::Text + +-- relIn has attributes "attributes"::relation {attribute::Text,type::Text} and "name"::Text +{- mkConversionTableContextFromRelation :: Relation -> TableContext mkConversionTableContextFromRelation relIn = TableContext $ relFold folder mempty relIn @@ -56,5 +63,13 @@ mkConversionTableContextFromRelation relIn = attrsFolder tup acc = case atomForAttributeName "attribute" tup of Left err -> pure acc - Right (Re + Right (TextAtom attrName) -> + case atomForAttributeName "type" tup of + Left err -> pure acc + Right (TextAtom typeName) -> + --convert typeName into AtomType + case readMaybe typeName of + Nothing -> pure acc + Just atomType -> Attribute attrName atomType : acc +-} diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/bin/SQL/Interpreter/Convert.hs index 42d33fe6..d900680b 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/bin/SQL/Interpreter/Convert.hs @@ -3,6 +3,7 @@ module SQL.Interpreter.Convert where import ProjectM36.Base as B import ProjectM36.Error +import ProjectM36.RelationalExpression import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A import ProjectM36.Relation (attributes) @@ -1106,3 +1107,12 @@ pushDownAttributeRename renameSet matchExpr targetExpr = RelationAtomExpr e -> RelationAtomExpr (push e) ConstructedAtomExpr dConsName args () -> ConstructedAtomExpr dConsName (pushAtom <$> args) () +mkTableContextFromDatabaseContext :: DatabaseContext -> TransactionGraph -> Either RelationalError TableContext +mkTableContextFromDatabaseContext dbc tgraph = do + TableContext . M.fromList <$> mapM rvMapper (M.toList (relationVariables dbc)) + where + rvMapper (nam, rvexpr) = do + let gfEnv = freshGraphRefRelationalExprEnv (Just dbc) tgraph + typeRel <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr rvexpr) + pure (TableAlias nam, + (RelationVariable nam (), attributes typeRel, mempty)) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 5acf5aed..7a26c6f1 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -147,6 +147,9 @@ newtype FuncName = FuncName [Text] data Distinctness = Distinct | All deriving (Show, Eq) +parseSelect :: Text -> Either ParserError Select +parseSelect = parse (queryExprP <* semi <* eof) "" + queryExprP :: Parser Select queryExprP = tableP <|> selectP diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs index 396dad8a..aacb6681 100644 --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -48,6 +48,7 @@ module ProjectM36.Client defaultHeadName, addClientNode, getDDLHash, + convertSQL, PersistenceStrategy(..), RelationalExpr, RelationalExprBase(..), @@ -167,6 +168,8 @@ import qualified Network.RPC.Curryer.Client as RPC import qualified Network.RPC.Curryer.Server as RPC import Network.Socket (Socket, AddrInfo(..), getAddrInfo, defaultHints, AddrInfoFlag(..), SocketType(..), ServiceName, hostAddressToTuple, SockAddr(..)) import GHC.Conc (unsafeIOToSTM) +import qualified Data.Text as T +import SQL.Interpreter.Convert type Hostname = String @@ -1095,6 +1098,33 @@ getDDLHash sessionId (InProcessConnection conf) = do pure (ddlHash ctx graph) getDDLHash sessionId conn@RemoteConnection{} = remoteCall conn (GetDDLHash sessionId) +-- | Convert an SQL expression into a RelationalExpr. Because the conversion process requires substantial database metadata access (such as retrieving types for various subexpressions), we cannot process SQL client-side. However, the underlying DBMS is completely unaware that the resultant RelationalExpr has come from SQL. +convertSQL :: SessionId -> Connection -> T.Text -> IO (Either RelationalError DF.DataFrameExpr) +convertSQL sessionId (InProcessConnection conf) sqlText = do + let sessions = ipSessions conf + graphTvar = ipTransactionGraph conf + atomically $ do + transGraph <- readTVar graphTvar + eSession <- sessionAndSchema sessionId sessions + case eSession of + Left err -> pure (Left err) + Right (session, schema) -> do + let ctx = Sess.concreteDatabaseContext session + reEnv = RE.mkRelationalExprEnv ctx transGraph + typeF = optimizeAndEvalRelationalExpr reEnv + tblcontext = mkTableContextFromDatabaseContext + -- parse SQL + case parseSelect sqlText of + Left err -> pure (Left (ParseError (T.pack (errorBundlePretty err)))) + Right selectExpr -> do + -- convert SQL data into DataFrameExpr + case evalConvertM tblcontext (convertSelect typeF selectExpr) of + Left err -> pure (Left (ParseError (T.pack (show err)))) + Right dfExpr -> pure (Right dfExpr) + + + + registeredQueriesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) registeredQueriesAsRelation sessionId (InProcessConnection conf) = do let sessions = ipSessions conf From ee971c5f1790c018b16614211a0010754cfe6b05 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 10 Mar 2024 01:23:19 -0500 Subject: [PATCH 061/170] add SQL support for adding data examples, update expressions, and commit+rollback --- project-m36.cabal | 12 +- src/bin/ProjectM36/Interpreter.hs | 29 +++ src/bin/SQL/Interpreter.hs | 110 +++++---- src/bin/SQL/Interpreter/ImportBasicExample.hs | 12 + src/bin/SQL/Interpreter/Select.hs | 162 +------------ .../Interpreter/TransactionGraphOperator.hs | 16 ++ src/bin/SQL/Interpreter/Update.hs | 26 +++ src/bin/SQL/Interpreter/sqlegacy.hs | 6 - src/bin/TutorialD/Interpreter.hs | 6 +- src/bin/TutorialD/Interpreter/Base.hs | 30 --- src/lib/ProjectM36/Client.hs | 47 ++-- src/lib/ProjectM36/Error.hs | 20 ++ .../ProjectM36/SQL}/Convert.hs | 57 +++-- src/lib/ProjectM36/SQL/Select.hs | 214 ++++++++++++++++++ src/lib/ProjectM36/SQL/Update.hs | 19 ++ src/lib/ProjectM36/Serialise/Error.hs | 1 + src/lib/ProjectM36/Server/EntryPoints.hs | 8 + src/lib/ProjectM36/Server/RemoteCallTypes.hs | 8 + 18 files changed, 486 insertions(+), 297 deletions(-) create mode 100644 src/bin/SQL/Interpreter/ImportBasicExample.hs create mode 100644 src/bin/SQL/Interpreter/TransactionGraphOperator.hs create mode 100644 src/bin/SQL/Interpreter/Update.hs rename src/{bin/SQL/Interpreter => lib/ProjectM36/SQL}/Convert.hs (97%) create mode 100644 src/lib/ProjectM36/SQL/Select.hs create mode 100644 src/lib/ProjectM36/SQL/Update.hs diff --git a/project-m36.cabal b/project-m36.cabal index 676b9fcc..14a059d1 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -136,7 +136,10 @@ Library ProjectM36.Trace, ProjectM36.HashSecurely, ProjectM36.DDLType, - ProjectM36.RegisteredQuery + ProjectM36.RegisteredQuery, + ProjectM36.SQL.Convert, + ProjectM36.SQL.Select, + ProjectM36.SQL.Update GHC-Options: -Wall -rdynamic if os(windows) Build-Depends: Win32 >= 2.12 @@ -278,11 +281,14 @@ Executable sqlegacy http-types, recursion-schemes, Other-Modules: SQL.Interpreter.Base, - SQL.Interpreter.Convert, SQL.Interpreter.Select, ProjectM36.Cli, ProjectM36.Interpreter, - SQL.Interpreter + SQL.Interpreter, + SQL.Interpreter.TransactionGraphOperator, + SQL.Interpreter.ImportBasicExample, + SQL.Interpreter.Update + Main-Is: ./SQL/Interpreter/sqlegacy.hs if os(windows) GHC-Options: -Wall -threaded -rtsopts diff --git a/src/bin/ProjectM36/Interpreter.hs b/src/bin/ProjectM36/Interpreter.hs index 5b26bfd7..53892032 100644 --- a/src/bin/ProjectM36/Interpreter.hs +++ b/src/bin/ProjectM36/Interpreter.hs @@ -2,11 +2,19 @@ -- functions common to both SQL and TutorialD interpreters module ProjectM36.Interpreter where import ProjectM36.Base +import ProjectM36.Error import ProjectM36.DataFrame import Text.Megaparsec import Data.Void import Data.Text import GHC.Generics +import qualified Data.Text.IO as TIO +import qualified Data.Text as T +import qualified Data.List.NonEmpty as NE +import System.IO +import Control.Monad.Random +import ProjectM36.Relation.Show.Term +import ProjectM36.Relation type Parser = Parsec Void Text type ParserError = ParseErrorBundle Text Void @@ -20,9 +28,30 @@ data ConsoleResult = QuitResult | DisplayRelationResult Relation | DisplayDataFrameResult DataFrame | DisplayErrorResult StringType | + DisplayRelationalErrorResult RelationalError | DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text QuietSuccessResult deriving (Generic) type InteractiveConsole = Bool +displayResult :: ConsoleResult -> IO () +displayResult QuitResult = return () +displayResult (DisplayResult out) = TIO.putStrLn out +displayResult (DisplayIOResult ioout) = ioout +displayResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in + outputf stderr ("ERR: " <> err) +displayResult QuietSuccessResult = return () +displayResult (DisplayRelationResult rel) = do + gen <- newStdGen + let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen + TIO.putStrLn (showRelation randomlySortedRel) +displayResult (DisplayParseErrorResult mPromptLength err) = do + let errorIndent = errorOffset . NE.head . bundleErrors $ err + errString = T.pack (parseErrorPretty . NE.head . bundleErrors $ err) + pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^" + maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength + TIO.putStr ("ERR:" <> errString) +displayResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame) +displayResult (DisplayRelationalErrorResult err) = + TIO.putStrLn ("ERR:" <> T.pack (show err)) diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs index 93d87c85..2db97a12 100644 --- a/src/bin/SQL/Interpreter.hs +++ b/src/bin/SQL/Interpreter.hs @@ -1,75 +1,85 @@ module SQL.Interpreter where import ProjectM36.Base import ProjectM36.Interpreter -import SQL.Interpreter.Base +import ProjectM36.SQL.Select +import ProjectM36.SQL.Update +import ProjectM36.DatabaseContext +import ProjectM36.DateExamples +import ProjectM36.Error +import SQL.Interpreter.ImportBasicExample +import SQL.Interpreter.TransactionGraphOperator import SQL.Interpreter.Select -import SQL.Interpreter.Convert +import SQL.Interpreter.Update import qualified Data.Text as T import qualified ProjectM36.Client as C import Text.Megaparsec -import Text.Megaparsec.Error -import Data.Void -import Text.Megaparsec.Char -import Data.Text (Text) - -data ImportBasicExampleOperator = ImportBasicExampleOperator T.Text - deriving (Show) +import SQL.Interpreter.Base data SQLCommand = RODatabaseContextOp Select | -- SELECT - DatabaseContextExprOp DatabaseContextExpr | -- UPDATE, DELETE, INSERT - ImportBasicExampleOp ImportBasicExampleOperator -- IMPORT EXAMPLE cjdate + DatabaseContextExprOp DatabaseContextExpr | + UpdateOp Update | -- UPDATE, DELETE, INSERT +-- InsertOp Insert | +-- DeleteOp Delete | + ImportBasicExampleOp ImportBasicExampleOperator | -- IMPORT EXAMPLE cjdate + TransactionGraphOp TransactionGraphOperator -- COMMIT, ROLLBACK deriving (Show) parseSQLUserInput :: T.Text -> Either ParserError SQLCommand -parseSQLUserInput = parse parseRODatabaseContextOp "" -- <|> parseDatabaseContextExprOp <|> parseImportBasicExampleOp) +parseSQLUserInput = parse ((parseRODatabaseContextOp <|> + parseDatabaseContextExprOp <|> + parseTransactionGraphOp <|> + parseImportBasicExampleOp) <* semi) "" parseRODatabaseContextOp :: Parser SQLCommand parseRODatabaseContextOp = RODatabaseContextOp <$> queryExprP +parseImportBasicExampleOp :: Parser SQLCommand +parseImportBasicExampleOp = ImportBasicExampleOp <$> importBasicExampleP + +parseTransactionGraphOp :: Parser SQLCommand +parseTransactionGraphOp = TransactionGraphOp <$> transactionGraphOperatorP + parseDatabaseContextExprOp :: Parser SQLCommand -parseDatabaseContextExprOp = undefined +parseDatabaseContextExprOp = UpdateOp <$> updateP -- <|> insertP) evalSQLInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> SQLCommand -> IO ConsoleResult -evalSQLInteractive sesssionId conn safeFlag interactiveConsole command = +evalSQLInteractive sessionId conn safeFlag interactiveConsole command = case command of RODatabaseContextOp sel -> do --get relvars to build conversion context - eRelExpr <- C.convertSQL sessionId conn sel - case eRelExpr of + eDFExpr <- C.convertSQLSelect sessionId conn sel + case eDFExpr of Left err -> pure $ DisplayRelationalErrorResult err - Right relExpr -> do - eRel <- C.executeRelationalExpr sessionId conn relExpr - case eRel of + Right dfExpr -> do + eDF <- C.executeDataFrameExpr sessionId conn dfExpr + case eDF of Left err -> pure $ DisplayRelationalErrorResult err - Right rel -> pure $ DisplayRelationResult rel - - - --- relIn has attributes "attributes"::relation {attribute::Text,type::Text} and "name"::Text -{- -mkConversionTableContextFromRelation :: Relation -> TableContext -mkConversionTableContextFromRelation relIn = - TableContext $ relFold folder mempty relIn + Right df -> pure $ DisplayDataFrameResult df + ImportBasicExampleOp (ImportBasicExampleOperator exampleName) -> do + if exampleName == "cjdate" then + evalSQLInteractive sessionId conn safeFlag interactiveConsole (DatabaseContextExprOp (databaseContextAsDatabaseContextExpr dateExamples)) + else + pure (DisplayErrorResult ("No such example: " <> exampleName)) + DatabaseContextExprOp dbcExpr -> do + eHandler $ C.executeDatabaseContextExpr sessionId conn dbcExpr + UpdateOp up -> do + eDBCExpr <- C.convertSQLUpdate sessionId conn up + case eDBCExpr of + Left err -> pure $ DisplayRelationalErrorResult err + Right dbcExpr -> + evalSQLInteractive sessionId conn safeFlag interactiveConsole (DatabaseContextExprOp dbcExpr) + TransactionGraphOp Commit -> do + eHandler $ C.commit sessionId conn + TransactionGraphOp Rollback -> do + eHandler $ C.rollback sessionId conn where - folder tup acc = - case atomForAttributeName "name" tup of - Left err -> pure acc - Right rvname -> - case atomForAttributeName "attributes" tup of - Left err -> pure acc - Right (RelationAtom attrsRel) -> - let attrs = attributesFromList $ relFold attrsFolder [] attrsRel - M.insert name (RelationVariable name (), attrs, mempty) - attrsFolder tup acc = - case atomForAttributeName "attribute" tup of - Left err -> pure acc - Right (TextAtom attrName) -> - case atomForAttributeName "type" tup of - Left err -> pure acc - Right (TextAtom typeName) -> - --convert typeName into AtomType - case readMaybe typeName of - Nothing -> pure acc - Just atomType -> Attribute attrName atomType : acc - --} + eHandler io = do + eErr <- io + case eErr of + Left err -> barf err + Right () -> return QuietSuccessResult + barf :: C.RelationalError -> IO ConsoleResult + barf (C.ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr)) + barf (C.ParseError err) = pure (DisplayErrorResult err) + barf err = return $ DisplayErrorResult (T.pack (show err)) + diff --git a/src/bin/SQL/Interpreter/ImportBasicExample.hs b/src/bin/SQL/Interpreter/ImportBasicExample.hs new file mode 100644 index 00000000..c5f558a9 --- /dev/null +++ b/src/bin/SQL/Interpreter/ImportBasicExample.hs @@ -0,0 +1,12 @@ +module SQL.Interpreter.ImportBasicExample where +import qualified Data.Text as T +import SQL.Interpreter.Base +import ProjectM36.Interpreter + +data ImportBasicExampleOperator = ImportBasicExampleOperator T.Text + deriving (Show) + +importBasicExampleP :: Parser ImportBasicExampleOperator +importBasicExampleP = do + reserveds "IMPORT EXAMPLE CJDATE" + pure (ImportBasicExampleOperator "cjdate") diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 7a26c6f1..69f8c5d9 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, DeriveTraversable, GeneralizedNewtypeDeriving #-} module SQL.Interpreter.Select where import ProjectM36.Interpreter +import ProjectM36.SQL.Select import Text.Megaparsec import Text.Megaparsec.Char import Control.Monad.Combinators.Expr as E @@ -8,144 +9,8 @@ import SQL.Interpreter.Base import Data.Text (Text, splitOn) import qualified Data.Text as T import Data.Functor -import Data.Functor.Foldable.TH import qualified Data.List.NonEmpty as NE --- we use an intermediate data structure because it may need to be probed into order to create a proper relational expression -data Select = Select { distinctness :: Maybe Distinctness, - projectionClause :: [SelectItem], - tableExpr :: Maybe TableExpr, - withClause :: Maybe WithClause - } - deriving (Show, Eq) - -emptySelect :: Select -emptySelect = Select { distinctness = Nothing, - projectionClause = [], - tableExpr = Nothing, - withClause = Nothing - } - -data WithClause = WithClause { isRecursive :: Bool, - withExprs :: NE.NonEmpty WithExpr } - deriving (Show, Eq) - -data WithExpr = WithExpr WithExprAlias Select - deriving (Show, Eq) - -newtype WithExprAlias = WithExprAlias Text - deriving (Show, Eq) - -data InFlag = In | NotIn - deriving (Show, Eq) - -data ComparisonOperator = OpLT | OpGT | OpGTE | OpEQ | OpNE | OpLTE - deriving (Show, Eq) - -data QuantifiedComparisonPredicate = QCAny | QCSome | QCAll - deriving (Show,Eq) - -data TableRef = SimpleTableRef TableName - | InnerJoinTableRef TableRef JoinCondition - | RightOuterJoinTableRef TableRef JoinCondition - | LeftOuterJoinTableRef TableRef JoinCondition - | FullOuterJoinTableRef TableRef JoinCondition - | CrossJoinTableRef TableRef - | NaturalJoinTableRef TableRef - | AliasedTableRef TableRef TableAlias - | QueryTableRef Select - deriving (Show, Eq) - --- distinguish between projection attributes which may include an asterisk and scalar expressions (such as in a where clause) where an asterisk is invalid -type ProjectionScalarExpr = ScalarExprBase ColumnProjectionName -type ScalarExpr = ScalarExprBase ColumnName - -data ScalarExprBase n = - IntegerLiteral Integer - | DoubleLiteral Double - | StringLiteral Text - | BooleanLiteral Bool - | NullLiteral - -- | Interval - | Identifier n - | BinaryOperator (ScalarExprBase n) OperatorName (ScalarExprBase n) - | PrefixOperator OperatorName (ScalarExprBase n) - | PostfixOperator (ScalarExprBase n) OperatorName - | BetweenOperator (ScalarExprBase n) (ScalarExprBase n) (ScalarExprBase n) - | FunctionApplication FuncName (ScalarExprBase n) - | CaseExpr { caseWhens :: [([ScalarExprBase n],ScalarExprBase n)], - caseElse :: Maybe (ScalarExprBase n) } - | QuantifiedComparison { qcExpr :: ScalarExprBase n, - qcOperator :: ComparisonOperator, - qcPredicate :: QuantifiedComparisonPredicate, - qcQuery :: Select } - - | InExpr InFlag (ScalarExprBase n) InPredicateValue - -- | ExistsSubQuery Select - -- | UniqueSubQuery Select - -- | ScalarSubQuery Select - | BooleanOperatorExpr (ScalarExprBase n) BoolOp (ScalarExprBase n) - | ExistsExpr Select - deriving (Show, Eq) - -data BoolOp = AndOp | OrOp - deriving (Eq, Show) - -data InPredicateValue = InList [ScalarExpr] | InQueryExpr Select | InScalarExpr ScalarExpr - deriving (Eq, Show) - -data GroupByExpr = Group ScalarExpr - deriving (Show, Eq) - -data HavingExpr = Having ScalarExpr - deriving (Show, Eq) - -data SortExpr = SortExpr ScalarExpr (Maybe Direction) (Maybe NullsOrder) - deriving (Show, Eq) - -data Direction = Ascending | Descending - deriving (Show, Eq) - -data NullsOrder = NullsFirst | NullsLast - deriving (Show, Eq) - -data JoinType = InnerJoin | RightOuterJoin | LeftOuterJoin | FullOuterJoin | CrossJoin | NaturalJoin - deriving (Show, Eq) - -data JoinCondition = JoinOn JoinOnCondition | JoinUsing [UnqualifiedColumnName] - deriving (Show, Eq) - -newtype JoinOnCondition = JoinOnCondition ScalarExpr - deriving (Show, Eq) - -data ColumnProjectionName = ColumnProjectionName [ProjectionName] --dot-delimited reference - deriving (Show, Eq, Ord) - -data ProjectionName = ProjectionName Text | Asterisk - deriving (Show, Eq, Ord) - -data ColumnName = ColumnName [Text] - deriving (Show, Eq, Ord) - -data UnqualifiedColumnName = UnqualifiedColumnName Text - deriving (Show, Eq, Ord) - -data TableName = TableName [Text] - deriving (Show, Eq, Ord) - -data OperatorName = OperatorName [Text] - deriving (Show, Eq, Ord) - -newtype ColumnAlias = ColumnAlias { unColumnAlias :: Text } - deriving (Show, Eq, Ord) - -newtype TableAlias = TableAlias { unTableAlias :: Text } - deriving (Show, Eq, Ord, Monoid, Semigroup) - -newtype FuncName = FuncName [Text] - deriving (Show, Eq) - -data Distinctness = Distinct | All deriving (Show, Eq) parseSelect :: Text -> Either ParserError Select parseSelect = parse (queryExprP <* semi <* eof) "" @@ -175,7 +40,6 @@ selectP = do withClause = withClause' }) -type SelectItem = (ProjectionScalarExpr, Maybe ColumnAlias) selectItemListP :: Parser [SelectItem] selectItemListP = sepBy1 selectItemP comma @@ -183,28 +47,6 @@ selectItemListP = sepBy1 selectItemP comma selectItemP :: Parser SelectItem selectItemP = (,) <$> scalarExprP <*> optional (reserved "as" *> columnAliasP) -newtype RestrictionExpr = RestrictionExpr ScalarExpr - deriving (Show, Eq) - -data TableExpr = - TableExpr { fromClause :: [TableRef], - whereClause :: Maybe RestrictionExpr, - groupByClause :: [GroupByExpr], - havingClause :: Maybe HavingExpr, - orderByClause :: [SortExpr], - limitClause :: Maybe Integer, - offsetClause :: Maybe Integer - } - deriving (Show, Eq) - -emptyTableExpr :: TableExpr -emptyTableExpr = TableExpr { fromClause = [], - whereClause = Nothing, - groupByClause = [], - havingClause = Nothing, - orderByClause = [], - limitClause = Nothing, - offsetClause = Nothing } tableExprP :: Parser TableExpr tableExprP = @@ -469,5 +311,5 @@ withP = do pure (WithExpr wName wSelect) pure (WithClause recursive (NE.fromList wExprs)) -makeBaseFunctor ''ScalarExprBase + diff --git a/src/bin/SQL/Interpreter/TransactionGraphOperator.hs b/src/bin/SQL/Interpreter/TransactionGraphOperator.hs new file mode 100644 index 00000000..193e1c7c --- /dev/null +++ b/src/bin/SQL/Interpreter/TransactionGraphOperator.hs @@ -0,0 +1,16 @@ +module SQL.Interpreter.TransactionGraphOperator where +import ProjectM36.Interpreter +import SQL.Interpreter.Base +import Control.Applicative + +data TransactionGraphOperator = Commit | Rollback + deriving (Show, Eq) + +transactionGraphOperatorP :: Parser TransactionGraphOperator +transactionGraphOperatorP = commitP <|> rollbackP + +commitP :: Parser TransactionGraphOperator +commitP = reserved "commit" *> pure Commit + +rollbackP :: Parser TransactionGraphOperator +rollbackP = reserved "rollback" *> pure Rollback diff --git a/src/bin/SQL/Interpreter/Update.hs b/src/bin/SQL/Interpreter/Update.hs new file mode 100644 index 00000000..9279f0f6 --- /dev/null +++ b/src/bin/SQL/Interpreter/Update.hs @@ -0,0 +1,26 @@ +module SQL.Interpreter.Update where +import SQL.Interpreter.Select +import ProjectM36.SQL.Update +import SQL.Interpreter.Base +import ProjectM36.Interpreter +import Control.Applicative +import Text.Megaparsec + +updateP :: Parser Update +updateP = do + reserved "update" + tname <- tableNameP + --mTAlias <- try (reserved "as" *> (Just <$> tableAliasP)) <|> pure Nothing + reserved "set" + setCols <- sepByComma1 $ do + calias <- unqualifiedColumnNameP + reserved "=" + sexpr <- scalarExprP + pure (calias, sexpr) + mWhere <- try (Just <$> whereP) <|> pure Nothing + pure (Update { + target = tname, +-- targetAlias = mTAlias, + setColumns = setCols, + mRestriction = mWhere + }) diff --git a/src/bin/SQL/Interpreter/sqlegacy.hs b/src/bin/SQL/Interpreter/sqlegacy.hs index a7ce7004..6edf0a13 100644 --- a/src/bin/SQL/Interpreter/sqlegacy.hs +++ b/src/bin/SQL/Interpreter/sqlegacy.hs @@ -1,6 +1,5 @@ -- the sqlegacy SQL interpreter wrap {-# LANGUAGE CPP #-} -import SQL.Interpreter.Convert import ProjectM36.Base import ProjectM36.Cli import SQL.Interpreter @@ -14,7 +13,6 @@ import Data.Either (fromRight) import Control.Exception (catchJust) import ProjectM36.Interpreter - #if !defined(VERSION_project_m36) # warning Failed to discover proper version from cabal_macros.h # define VERSION_project_m36 "" @@ -49,7 +47,3 @@ promptText eHeadName eSchemaName = "SQLegacy (" <> transInfo <> "): " where transInfo = fromRight "" eHeadName <> "/" <> fromRight "" eSchemaName - -displayResult :: ConsoleResult -> IO () -displayResult = undefined - diff --git a/src/bin/TutorialD/Interpreter.hs b/src/bin/TutorialD/Interpreter.hs index ee0c5d77..3babc698 100644 --- a/src/bin/TutorialD/Interpreter.hs +++ b/src/bin/TutorialD/Interpreter.hs @@ -226,10 +226,10 @@ runTutorialD :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> I runTutorialD sessionId conn mPromptLength tutd = case parseTutorialD tutd of Left err -> - displayOpResult $ DisplayParseErrorResult mPromptLength err + displayResult $ DisplayParseErrorResult mPromptLength err Right parsed -> catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do evald <- evalTutorialDInteractive sessionId conn UnsafeEvaluation True parsed - displayOpResult evald) - (\_ -> displayOpResult (DisplayErrorResult "Request timed out.")) + displayResult evald) + (\_ -> displayResult (DisplayErrorResult "Request timed out.")) diff --git a/src/bin/TutorialD/Interpreter/Base.hs b/src/bin/TutorialD/Interpreter/Base.hs index 4d3a11e5..06f9a9b9 100644 --- a/src/bin/TutorialD/Interpreter/Base.hs +++ b/src/bin/TutorialD/Interpreter/Base.hs @@ -13,8 +13,6 @@ module TutorialD.Interpreter.Base ( import ProjectM36.Base import ProjectM36.AtomType import ProjectM36.Attribute as A -import ProjectM36.Relation -import ProjectM36.DataFrame import ProjectM36.Interpreter #if MIN_VERSION_megaparsec(6,0,0) @@ -28,18 +26,13 @@ import qualified Text.Megaparsec.Lexer as Lex #endif import Data.Text hiding (count) -import System.Random import qualified Data.Text as T import qualified Data.List as L -import qualified Data.Text.IO as TIO -import System.IO -import ProjectM36.Relation.Show.Term #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif import qualified Data.UUID as U import Control.Monad.Random -import Data.List.NonEmpty as NE import Data.Time.Clock import Data.Time.Format import Data.Char @@ -49,29 +42,6 @@ anySingle :: Parsec Void Text (Token Text) anySingle = anyChar #endif -displayOpResult :: ConsoleResult -> IO () -displayOpResult QuitResult = return () -displayOpResult (DisplayResult out) = TIO.putStrLn out -displayOpResult (DisplayIOResult ioout) = ioout -displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in - outputf stderr ("ERR: " <> err) -displayOpResult QuietSuccessResult = return () -displayOpResult (DisplayRelationResult rel) = do - gen <- newStdGen - let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen - TIO.putStrLn (showRelation randomlySortedRel) -displayOpResult (DisplayParseErrorResult mPromptLength err) = do -#if MIN_VERSION_megaparsec(7,0,0) - let errorIndent = errorOffset . NE.head . bundleErrors $ err - errString = T.pack (parseErrorPretty . NE.head . bundleErrors $ err) -#else - let errorIndent = unPos (sourceColumn (NE.head (errorPos err))) - errString = T.pack (parseErrorPretty err) -#endif - pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^" - maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength - TIO.putStr ("ERR:" <> errString) -displayOpResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame) type ParseStr = Text diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs index aacb6681..e6d4ab7e 100644 --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -48,7 +48,8 @@ module ProjectM36.Client defaultHeadName, addClientNode, getDDLHash, - convertSQL, + convertSQLSelect, + convertSQLUpdate, PersistenceStrategy(..), RelationalExpr, RelationalExprBase(..), @@ -168,8 +169,9 @@ import qualified Network.RPC.Curryer.Client as RPC import qualified Network.RPC.Curryer.Server as RPC import Network.Socket (Socket, AddrInfo(..), getAddrInfo, defaultHints, AddrInfoFlag(..), SocketType(..), ServiceName, hostAddressToTuple, SockAddr(..)) import GHC.Conc (unsafeIOToSTM) -import qualified Data.Text as T -import SQL.Interpreter.Convert +import ProjectM36.SQL.Select as SQL +import ProjectM36.SQL.Update as SQL +import ProjectM36.SQL.Convert type Hostname = String @@ -1098,9 +1100,9 @@ getDDLHash sessionId (InProcessConnection conf) = do pure (ddlHash ctx graph) getDDLHash sessionId conn@RemoteConnection{} = remoteCall conn (GetDDLHash sessionId) --- | Convert an SQL expression into a RelationalExpr. Because the conversion process requires substantial database metadata access (such as retrieving types for various subexpressions), we cannot process SQL client-side. However, the underlying DBMS is completely unaware that the resultant RelationalExpr has come from SQL. -convertSQL :: SessionId -> Connection -> T.Text -> IO (Either RelationalError DF.DataFrameExpr) -convertSQL sessionId (InProcessConnection conf) sqlText = do +-- | Convert a SQL Select expression into a DataFrameExpr. Because the conversion process requires substantial database metadata access (such as retrieving types for various subexpressions), we cannot process SQL client-side. However, the underlying DBMS is completely unaware that the resultant DataFrameExpr has come from SQL. +convertSQLSelect :: SessionId -> Connection -> Select -> IO (Either RelationalError DF.DataFrameExpr) +convertSQLSelect sessionId (InProcessConnection conf) sel = do let sessions = ipSessions conf graphTvar = ipTransactionGraph conf atomically $ do @@ -1108,23 +1110,36 @@ convertSQL sessionId (InProcessConnection conf) sqlText = do eSession <- sessionAndSchema sessionId sessions case eSession of Left err -> pure (Left err) - Right (session, schema) -> do + Right (session, _schema) -> do -- TODO: enable SQL to leverage isomorphic schemas let ctx = Sess.concreteDatabaseContext session reEnv = RE.mkRelationalExprEnv ctx transGraph typeF = optimizeAndEvalRelationalExpr reEnv - tblcontext = mkTableContextFromDatabaseContext - -- parse SQL - case parseSelect sqlText of - Left err -> pure (Left (ParseError (T.pack (errorBundlePretty err)))) - Right selectExpr -> do -- convert SQL data into DataFrameExpr - case evalConvertM tblcontext (convertSelect typeF selectExpr) of - Left err -> pure (Left (ParseError (T.pack (show err)))) - Right dfExpr -> pure (Right dfExpr) + case evalConvertM mempty (convertSelect typeF sel) of + Left err -> pure (Left (SQLConversionError err)) + Right dfExpr -> pure (Right dfExpr) +convertSQLSelect sessionId conn@RemoteConnection{} sel = remoteCall conn (ConvertSQLSelect sessionId sel) +convertSQLUpdate :: SessionId -> Connection -> SQL.Update -> IO (Either RelationalError DatabaseContextExpr) +convertSQLUpdate sessionId (InProcessConnection conf) update = do + let sessions = ipSessions conf + graphTvar = ipTransactionGraph conf + atomically $ do + transGraph <- readTVar graphTvar + eSession <- sessionAndSchema sessionId sessions + case eSession of + Left err -> pure (Left err) + Right (session, _schema) -> do -- TODO: enable SQL to leverage isomorphic schemas + let ctx = Sess.concreteDatabaseContext session + reEnv = RE.mkRelationalExprEnv ctx transGraph + typeF = optimizeAndEvalRelationalExpr reEnv + -- convert SQL data into DataFrameExpr + case evalConvertM mempty (convertUpdate typeF update) of + Left err -> pure (Left (SQLConversionError err)) + Right updateExpr -> pure (Right updateExpr) +convertSQLUpdate sessionId conn@RemoteConnection{} up = remoteCall conn (ConvertSQLUpdate sessionId up) - registeredQueriesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) registeredQueriesAsRelation sessionId (InProcessConnection conf) = do let sessions = ipSessions conf diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs index a5d2c401..4d190e15 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -11,6 +11,7 @@ import GHC.Generics (Generic) import qualified Data.Text as T import Data.Typeable import Control.Exception +import ProjectM36.SQL.Select data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName) | TupleAttributeCountMismatchError Int --attribute name @@ -109,6 +110,8 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName) | RegisteredQueryNameInUseError RegisteredQueryName | RegisteredQueryNameNotInUseError RegisteredQueryName + | SQLConversionError SQLError + | MultipleErrors [RelationalError] deriving (Show,Eq,Generic,Typeable, NFData) @@ -159,3 +162,20 @@ data ImportError' = InvalidSHA256Error T.Text | ImportFileError T.Text | ImportDownloadError T.Text deriving (Show, Eq, Generic, Typeable, NFData) + +data SQLError = NotSupportedError T.Text | + TypeMismatchError AtomType AtomType | + NoSuchSQLFunctionError FuncName | + DuplicateTableReferenceError TableAlias | + MissingTableReferenceError TableAlias | + TableAliasMismatchError TableAlias | + UnexpectedTableNameError TableName | + UnexpectedColumnNameError ColumnName | + ColumnResolutionError ColumnName | + ColumnAliasResolutionError ColumnAlias | + UnexpectedRelationalExprError RelationalExpr | + UnexpectedAsteriskError ColumnProjectionName | + AmbiguousColumnResolutionError ColumnName | + DuplicateColumnAliasError ColumnAlias | + SQLRelationalError RelationalError + deriving (Show, Eq, Generic, Typeable, NFData) diff --git a/src/bin/SQL/Interpreter/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs similarity index 97% rename from src/bin/SQL/Interpreter/Convert.hs rename to src/lib/ProjectM36/SQL/Convert.hs index d900680b..ba24c9d4 100644 --- a/src/bin/SQL/Interpreter/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -1,14 +1,15 @@ --convert SQL into relational or database context expressions {-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables, TypeApplications, GeneralizedNewtypeDeriving #-} -module SQL.Interpreter.Convert where +module ProjectM36.SQL.Convert where import ProjectM36.Base as B import ProjectM36.Error +import ProjectM36.SQL.Select +import ProjectM36.SQL.Update as SQL import ProjectM36.RelationalExpression import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A import ProjectM36.Relation (attributes) import qualified ProjectM36.Attribute as A -import SQL.Interpreter.Select import qualified Data.Text as T import qualified ProjectM36.WithNameExpr as With import Control.Monad (foldM) @@ -34,22 +35,9 @@ TODO * remove traceShow* -} -data SQLError = NotSupportedError T.Text | - TypeMismatchError AtomType AtomType | - NoSuchSQLFunctionError FuncName | - DuplicateTableReferenceError TableAlias | - MissingTableReferenceError TableAlias | - TableAliasMismatchError TableAlias | - UnexpectedTableNameError TableName | - UnexpectedColumnNameError ColumnName | - ColumnResolutionError ColumnName | - ColumnAliasResolutionError ColumnAlias | - UnexpectedRelationalExprError RelationalExpr | - UnexpectedAsteriskError ColumnProjectionName | - AmbiguousColumnResolutionError ColumnName | - DuplicateColumnAliasError ColumnAlias | - SQLRelationalError RelationalError - deriving (Show, Eq) +--over the course of conversion of a table expression, we collect all the table aliases we encounter, including non-aliased table references, including the type of the table, projections have their own name resolution system +newtype TableContext = TableContext (M.Map TableAlias (RelationalExpr, Attributes, ColumnAliasRemapper)) + deriving (Semigroup, Monoid, Show, Eq) type TypeForRelExprF = RelationalExpr -> Either RelationalError Relation @@ -66,10 +54,6 @@ data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set taskExtenders :: [ExtendTupleExpr] } deriving (Show, Eq) ---over the course of conversion of a table expression, we collect all the table aliases we encounter, including non-aliased table references, including the type of the table, projections have their own name resolution system -newtype TableContext = TableContext (M.Map TableAlias (RelationalExpr, Attributes, ColumnAliasRemapper)) - deriving (Semigroup, Monoid, Show, Eq) - -- (real attribute name in table- immutable, (renamed "preferred" attribute name needed to disambiguate names on conflict, set of names which are used to reference the "preferred" name) type AttributeAlias = AttributeName -- the AttributeAlias is necessary when then is otherwise a naming conflict such as with join conditions which would otherwise cause duplicate column names which SQL supports but the relational algebra does not @@ -149,7 +133,7 @@ withSubSelect m = do -- diff the state to get just the items that were added -- traceShowM ("keys orig"::String, M.keys orig) -- traceShowM ("keys postSub"::String, M.keys postSub) - let tableDiffFolder acc (tAlias, (RelationVariable rv (), _ , colAliasRemapper)) = do + let tableDiffFolder acc (tAlias, (RelationVariable _rv (), _ , colAliasRemapper)) = do let convertColAliases :: ColumnAliasRemapper -> (AttributeName, (AttributeName, S.Set ColumnName)) -> ColumnAliasRenameMap -> ColumnAliasRenameMap convertColAliases origColAlRemapper (attrName, (attrAlias,_)) acc' = if M.member attrName origColAlRemapper then @@ -161,9 +145,8 @@ withSubSelect m = do Nothing -> do pure (acc <> foldr (convertColAliases mempty) mempty (M.toList colAliasRemapper)) -- we are aware of the table, but there may have been some new columns added - Just (_,_,colAliasRemapper) -> - pure (acc <> foldr (convertColAliases colAliasRemapper) mempty (M.toList colAliasRemapper)) - x -> throwSQLE (NotSupportedError $ "unhandled withSubSelect diff: " <> T.pack (show x)) + Just (_,_,colAliasRemapper') -> + pure (acc <> foldr (convertColAliases colAliasRemapper') mempty (M.toList colAliasRemapper')) diff <- foldM tableDiffFolder mempty (M.toList postSub) @@ -246,11 +229,11 @@ noteColumnMention mTblAlias colName mColAlias = do --traceStateM let sqlColAlias = fromMaybe colAttr (unColumnAlias <$> mColAlias) colAlias' <- case findNotedColumn' (ColumnName [colAttr]) tc of - Left err -> -- no match, so table prefix not required + Left _ -> -- no match, so table prefix not required insertColAlias sqlColAlias Right [] -> -- no match, so table prefix not required insertColAlias sqlColAlias - Right [match] -> -- we have a match, so we need the table prefix + Right [_] -> -- we have a match, so we need the table prefix insertColAlias (fromMaybe tPrefixColAttr (unColumnAlias <$> mColAlias)) Right (_:_) -> throwSQLE (AmbiguousColumnResolutionError colName) --traceShowM ("findNotedColumn' in noteColumnMentionB"::String, colAlias') @@ -1043,6 +1026,7 @@ needsToRenameAllAttributes (RestrictionExpr sexpr) = StringLiteral{} -> False IntegerLiteral{} -> False NullLiteral{} -> False + BooleanLiteral{} -> False Identifier{} -> False BinaryOperator e1 _ e2 -> rec' e1 || rec' e2 PrefixOperator _ e1 -> rec' e1 @@ -1052,7 +1036,7 @@ needsToRenameAllAttributes (RestrictionExpr sexpr) = CaseExpr cases else' -> or (map (\(whens, then') -> or (map rec' whens) || rec' then') cases) QuantifiedComparison{} -> True - InExpr _ sexpr' _ -> rec' sexpr' + InExpr _ sexpr'' _ -> rec' sexpr'' BooleanOperatorExpr e1 _ e2 -> rec' e1 || rec' e2 ExistsExpr{} -> True @@ -1116,3 +1100,18 @@ mkTableContextFromDatabaseContext dbc tgraph = do typeRel <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr rvexpr) pure (TableAlias nam, (RelationVariable nam (), attributes typeRel, mempty)) + +convertUpdate :: TypeForRelExprF -> Update -> ConvertM DatabaseContextExpr +convertUpdate typeF up = do + let convertSetColumns (UnqualifiedColumnName colName, sexpr) = do + (,) <$> pure colName <*> convertScalarExpr typeF sexpr + atomMap <- M.fromList <$> mapM convertSetColumns (setColumns up) + restrictionExpr <- case mRestriction up of + Nothing -> pure TruePredicate + Just restriction -> convertWhereClause typeF restriction + rvname <- convertTableName (target up) + pure (B.Update rvname atomMap restrictionExpr) + +convertTableName :: TableName -> ConvertM RelVarName +convertTableName (TableName [tname]) = pure tname +convertTableName t@TableName{} = throwSQLE (UnexpectedTableNameError t) diff --git a/src/lib/ProjectM36/SQL/Select.hs b/src/lib/ProjectM36/SQL/Select.hs new file mode 100644 index 00000000..e878d690 --- /dev/null +++ b/src/lib/ProjectM36/SQL/Select.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, DeriveTraversable, GeneralizedNewtypeDeriving, DerivingVia, DeriveAnyClass, DeriveGeneric, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-} +module ProjectM36.SQL.Select where +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Data.Functor.Foldable.TH +import Codec.Winery +import GHC.Generics +import Control.DeepSeq + +-- we use an intermediate data structure because it may need to be probed into order to create a proper relational expression +data Select = Select { distinctness :: Maybe Distinctness, + projectionClause :: [SelectItem], + tableExpr :: Maybe TableExpr, + withClause :: Maybe WithClause + } + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryRecord Select + +emptySelect :: Select +emptySelect = Select { distinctness = Nothing, + projectionClause = [], + tableExpr = Nothing, + withClause = Nothing + } + +type SelectItem = (ProjectionScalarExpr, Maybe ColumnAlias) + +data WithClause = WithClause { isRecursive :: Bool, + withExprs :: NE.NonEmpty WithExpr } + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryRecord WithClause + +data WithExpr = WithExpr WithExprAlias Select + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant WithExpr + +newtype WithExprAlias = WithExprAlias Text + deriving (Show, Eq, Generic) + deriving Serialise via WineryVariant WithExprAlias + deriving newtype NFData + +data InFlag = In | NotIn + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant InFlag + +data ComparisonOperator = OpLT | OpGT | OpGTE | OpEQ | OpNE | OpLTE + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant ComparisonOperator + +data QuantifiedComparisonPredicate = QCAny | QCSome | QCAll + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant QuantifiedComparisonPredicate + +data TableRef = SimpleTableRef TableName + | InnerJoinTableRef TableRef JoinCondition + | RightOuterJoinTableRef TableRef JoinCondition + | LeftOuterJoinTableRef TableRef JoinCondition + | FullOuterJoinTableRef TableRef JoinCondition + | CrossJoinTableRef TableRef + | NaturalJoinTableRef TableRef + | AliasedTableRef TableRef TableAlias + | QueryTableRef Select + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant TableRef + +-- distinguish between projection attributes which may include an asterisk and scalar expressions (such as in a where clause) where an asterisk is invalid +type ProjectionScalarExpr = ScalarExprBase ColumnProjectionName + +deriving via WineryVariant ProjectionScalarExpr instance Serialise ProjectionScalarExpr + +type ScalarExpr = ScalarExprBase ColumnName + +deriving via WineryVariant ScalarExpr instance Serialise ScalarExpr + +data ScalarExprBase n = + IntegerLiteral Integer + | DoubleLiteral Double + | StringLiteral Text + | BooleanLiteral Bool + | NullLiteral + -- | Interval + | Identifier n + | BinaryOperator (ScalarExprBase n) OperatorName (ScalarExprBase n) + | PrefixOperator OperatorName (ScalarExprBase n) + | PostfixOperator (ScalarExprBase n) OperatorName + | BetweenOperator (ScalarExprBase n) (ScalarExprBase n) (ScalarExprBase n) + | FunctionApplication FuncName (ScalarExprBase n) + | CaseExpr { caseWhens :: [([ScalarExprBase n],ScalarExprBase n)], + caseElse :: Maybe (ScalarExprBase n) } + | QuantifiedComparison { qcExpr :: ScalarExprBase n, + qcOperator :: ComparisonOperator, + qcPredicate :: QuantifiedComparisonPredicate, + qcQuery :: Select } + + | InExpr InFlag (ScalarExprBase n) InPredicateValue + -- | ExistsSubQuery Select + -- | UniqueSubQuery Select + -- | ScalarSubQuery Select + | BooleanOperatorExpr (ScalarExprBase n) BoolOp (ScalarExprBase n) + | ExistsExpr Select + deriving (Show, Eq, Generic, NFData) + +data BoolOp = AndOp | OrOp + deriving (Eq, Show, Generic, NFData) + deriving Serialise via WineryVariant BoolOp + +data InPredicateValue = InList [ScalarExpr] | InQueryExpr Select | InScalarExpr ScalarExpr + deriving (Eq, Show, Generic, NFData) + deriving Serialise via WineryVariant InPredicateValue + +data GroupByExpr = Group ScalarExpr + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant GroupByExpr + +data HavingExpr = Having ScalarExpr + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant HavingExpr + +data SortExpr = SortExpr ScalarExpr (Maybe Direction) (Maybe NullsOrder) + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant SortExpr + +data Direction = Ascending | Descending + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant Direction + +data NullsOrder = NullsFirst | NullsLast + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant NullsOrder + +data JoinType = InnerJoin | RightOuterJoin | LeftOuterJoin | FullOuterJoin | CrossJoin | NaturalJoin + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant JoinType + +data JoinCondition = JoinOn JoinOnCondition | JoinUsing [UnqualifiedColumnName] + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant JoinCondition + +newtype JoinOnCondition = JoinOnCondition ScalarExpr + deriving (Show, Eq, Generic) + deriving Serialise via WineryVariant JoinOnCondition + deriving newtype NFData + +data ColumnProjectionName = ColumnProjectionName [ProjectionName] --dot-delimited reference + deriving (Show, Eq, Ord, Generic, NFData) + deriving Serialise via WineryVariant ColumnProjectionName + +data ProjectionName = ProjectionName Text | Asterisk + deriving (Show, Eq, Ord, Generic, NFData) + deriving Serialise via WineryVariant ProjectionName + +data ColumnName = ColumnName [Text] + deriving (Show, Eq, Ord, Generic, NFData) + deriving Serialise via WineryVariant ColumnName + +data UnqualifiedColumnName = UnqualifiedColumnName Text + deriving (Show, Eq, Ord, Generic, NFData) + deriving Serialise via WineryVariant UnqualifiedColumnName + +data TableName = TableName [Text] + deriving (Show, Eq, Ord, Generic, NFData) + deriving Serialise via WineryVariant TableName + +data OperatorName = OperatorName [Text] + deriving (Show, Eq, Ord, Generic, NFData) + deriving Serialise via WineryVariant OperatorName + +newtype ColumnAlias = ColumnAlias { unColumnAlias :: Text } + deriving (Show, Eq, Ord, Generic) + deriving Serialise via WineryVariant ColumnAlias + deriving newtype NFData + +newtype TableAlias = TableAlias { unTableAlias :: Text } + deriving (Show, Eq, Ord, Generic) + deriving Serialise via WineryVariant TableAlias + deriving newtype (Monoid, Semigroup, NFData) + +newtype FuncName = FuncName [Text] + deriving (Show, Eq, Generic) + deriving Serialise via WineryVariant FuncName + deriving newtype NFData + +data Distinctness = Distinct | All + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant Distinctness + +newtype RestrictionExpr = RestrictionExpr ScalarExpr + deriving (Show, Eq, Generic) + deriving Serialise via WineryVariant RestrictionExpr + deriving newtype NFData + +data TableExpr = + TableExpr { fromClause :: [TableRef], + whereClause :: Maybe RestrictionExpr, + groupByClause :: [GroupByExpr], + havingClause :: Maybe HavingExpr, + orderByClause :: [SortExpr], + limitClause :: Maybe Integer, + offsetClause :: Maybe Integer + } + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryRecord TableExpr + +emptyTableExpr :: TableExpr +emptyTableExpr = TableExpr { fromClause = [], + whereClause = Nothing, + groupByClause = [], + havingClause = Nothing, + orderByClause = [], + limitClause = Nothing, + offsetClause = Nothing } + +makeBaseFunctor ''ScalarExprBase + diff --git a/src/lib/ProjectM36/SQL/Update.hs b/src/lib/ProjectM36/SQL/Update.hs new file mode 100644 index 00000000..3eb071eb --- /dev/null +++ b/src/lib/ProjectM36/SQL/Update.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +module ProjectM36.SQL.Update where +import ProjectM36.SQL.Select +import ProjectM36.Serialise.Base () +import Control.DeepSeq +import Codec.Winery +import GHC.Generics + +data Update = Update + { target :: TableName, +-- targetAlias :: Maybe TableAlias, + --SET + setColumns :: [(UnqualifiedColumnName, ScalarExpr)], --we don't support multi-column SET yet + mRestriction :: Maybe RestrictionExpr + } + --RETURNING not yet supported + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryRecord Update + diff --git a/src/lib/ProjectM36/Serialise/Error.hs b/src/lib/ProjectM36/Serialise/Error.hs index 92377e6c..b474000b 100644 --- a/src/lib/ProjectM36/Serialise/Error.hs +++ b/src/lib/ProjectM36/Serialise/Error.hs @@ -13,3 +13,4 @@ deriving via WineryVariant ScriptCompilationError instance Serialise ScriptCompi deriving via WineryVariant PersistenceError instance Serialise PersistenceError deriving via WineryVariant SchemaError instance Serialise SchemaError deriving via WineryVariant ImportError' instance Serialise ImportError' +deriving via WineryVariant SQLError instance Serialise SQLError diff --git a/src/lib/ProjectM36/Server/EntryPoints.hs b/src/lib/ProjectM36/Server/EntryPoints.hs index aa49f074..71b8311d 100644 --- a/src/lib/ProjectM36/Server/EntryPoints.hs +++ b/src/lib/ProjectM36/Server/EntryPoints.hs @@ -3,6 +3,8 @@ module ProjectM36.Server.EntryPoints where import ProjectM36.Base hiding (inclusionDependencies) import ProjectM36.IsomorphicSchema import ProjectM36.HashSecurely +import ProjectM36.SQL.Select +import ProjectM36.SQL.Update import ProjectM36.Client as C import Data.Map import Control.Concurrent (threadDelay) @@ -157,3 +159,9 @@ handleRetrieveDDLAsRelation ti sessionId conn = handleRetrieveRegisteredQueries :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation) handleRetrieveRegisteredQueries ti sessionId conn = timeoutRelErr ti (C.registeredQueriesAsRelation sessionId conn) + +handleConvertSQLSelect :: Maybe Timeout -> SessionId -> Connection -> Select -> IO (Either RelationalError DataFrameExpr) +handleConvertSQLSelect ti sessionId conn sel = timeoutRelErr ti (C.convertSQLSelect sessionId conn sel) + +handleConvertSQLUpdate :: Maybe Timeout -> SessionId -> Connection -> Update -> IO (Either RelationalError DatabaseContextExpr) +handleConvertSQLUpdate ti sessionId conn up = timeoutRelErr ti (C.convertSQLUpdate sessionId conn up) diff --git a/src/lib/ProjectM36/Server/RemoteCallTypes.hs b/src/lib/ProjectM36/Server/RemoteCallTypes.hs index b784191f..723d5642 100644 --- a/src/lib/ProjectM36/Server/RemoteCallTypes.hs +++ b/src/lib/ProjectM36/Server/RemoteCallTypes.hs @@ -8,6 +8,8 @@ import ProjectM36.TransGraphRelationalExpression import ProjectM36.Session import ProjectM36.Serialise.DataFrame () import ProjectM36.Serialise.IsomorphicSchema () +import ProjectM36.SQL.Select +import ProjectM36.SQL.Update import GHC.Generics import Codec.Winery @@ -110,3 +112,9 @@ data RetrieveDDLAsRelation = RetrieveDDLAsRelation SessionId data RetrieveRegisteredQueries = RetrieveRegisteredQueries SessionId RPCData(RetrieveRegisteredQueries) + +data ConvertSQLSelect = ConvertSQLSelect SessionId Select + RPCData(ConvertSQLSelect) + +data ConvertSQLUpdate = ConvertSQLUpdate SessionId Update + RPCData(ConvertSQLUpdate) From bcc1fef05056f5ed6a1c54466eb3191cf4958325 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 10 Mar 2024 23:13:36 -0400 Subject: [PATCH 062/170] refactor Select+Query types add multi-SQL-expression DBUpdate function via Client for batch jobs basic INSERT, UPDATE, DELETE support functioning --- project-m36.cabal | 10 ++- src/bin/SQL/Interpreter.hs | 28 ++++---- src/bin/SQL/Interpreter/DBUpdate.hs | 17 +++++ src/bin/SQL/Interpreter/Delete.hs | 15 +++++ src/bin/SQL/Interpreter/Insert.hs | 15 +++++ src/bin/SQL/Interpreter/Select.hs | 24 +++++-- src/lib/ProjectM36/Client.hs | 27 ++++---- src/lib/ProjectM36/Error.hs | 1 + src/lib/ProjectM36/SQL/Convert.hs | 71 ++++++++++++++++++-- src/lib/ProjectM36/SQL/DBUpdate.hs | 17 +++++ src/lib/ProjectM36/SQL/Delete.hs | 12 ++++ src/lib/ProjectM36/SQL/Insert.hs | 16 +++++ src/lib/ProjectM36/SQL/Select.hs | 7 +- src/lib/ProjectM36/SQL/Update.hs | 2 +- src/lib/ProjectM36/Server/EntryPoints.hs | 10 +-- src/lib/ProjectM36/Server/RemoteCallTypes.hs | 10 +-- 16 files changed, 228 insertions(+), 54 deletions(-) create mode 100644 src/bin/SQL/Interpreter/DBUpdate.hs create mode 100644 src/bin/SQL/Interpreter/Delete.hs create mode 100644 src/bin/SQL/Interpreter/Insert.hs create mode 100644 src/lib/ProjectM36/SQL/DBUpdate.hs create mode 100644 src/lib/ProjectM36/SQL/Delete.hs create mode 100644 src/lib/ProjectM36/SQL/Insert.hs diff --git a/project-m36.cabal b/project-m36.cabal index 14a059d1..533eaec9 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -139,7 +139,10 @@ Library ProjectM36.RegisteredQuery, ProjectM36.SQL.Convert, ProjectM36.SQL.Select, - ProjectM36.SQL.Update + ProjectM36.SQL.Update, + ProjectM36.SQL.Insert, + ProjectM36.SQL.Delete, + ProjectM36.SQL.DBUpdate GHC-Options: -Wall -rdynamic if os(windows) Build-Depends: Win32 >= 2.12 @@ -287,7 +290,10 @@ Executable sqlegacy SQL.Interpreter, SQL.Interpreter.TransactionGraphOperator, SQL.Interpreter.ImportBasicExample, - SQL.Interpreter.Update + SQL.Interpreter.Update, + SQL.Interpreter.Insert, + SQL.Interpreter.Delete, + SQL.Interpreter.DBUpdate Main-Is: ./SQL/Interpreter/sqlegacy.hs if os(windows) diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs index 2db97a12..a48e9334 100644 --- a/src/bin/SQL/Interpreter.hs +++ b/src/bin/SQL/Interpreter.hs @@ -2,36 +2,34 @@ module SQL.Interpreter where import ProjectM36.Base import ProjectM36.Interpreter import ProjectM36.SQL.Select -import ProjectM36.SQL.Update import ProjectM36.DatabaseContext import ProjectM36.DateExamples import ProjectM36.Error import SQL.Interpreter.ImportBasicExample import SQL.Interpreter.TransactionGraphOperator import SQL.Interpreter.Select -import SQL.Interpreter.Update +import SQL.Interpreter.DBUpdate +import ProjectM36.SQL.DBUpdate import qualified Data.Text as T import qualified ProjectM36.Client as C import Text.Megaparsec import SQL.Interpreter.Base -data SQLCommand = RODatabaseContextOp Select | -- SELECT +data SQLCommand = RODatabaseContextOp Query | -- SELECT DatabaseContextExprOp DatabaseContextExpr | - UpdateOp Update | -- UPDATE, DELETE, INSERT --- InsertOp Insert | --- DeleteOp Delete | + DBUpdateOp [DBUpdate] | -- INSERT, UPDATE, DELETE ImportBasicExampleOp ImportBasicExampleOperator | -- IMPORT EXAMPLE cjdate TransactionGraphOp TransactionGraphOperator -- COMMIT, ROLLBACK deriving (Show) parseSQLUserInput :: T.Text -> Either ParserError SQLCommand -parseSQLUserInput = parse ((parseRODatabaseContextOp <|> +parseSQLUserInput = parse ((parseRODatabaseContextOp <* semi) <|> parseDatabaseContextExprOp <|> - parseTransactionGraphOp <|> - parseImportBasicExampleOp) <* semi) "" + (parseTransactionGraphOp <* semi) <|> + (parseImportBasicExampleOp <* semi)) "" parseRODatabaseContextOp :: Parser SQLCommand -parseRODatabaseContextOp = RODatabaseContextOp <$> queryExprP +parseRODatabaseContextOp = RODatabaseContextOp <$> queryP parseImportBasicExampleOp :: Parser SQLCommand parseImportBasicExampleOp = ImportBasicExampleOp <$> importBasicExampleP @@ -40,14 +38,14 @@ parseTransactionGraphOp :: Parser SQLCommand parseTransactionGraphOp = TransactionGraphOp <$> transactionGraphOperatorP parseDatabaseContextExprOp :: Parser SQLCommand -parseDatabaseContextExprOp = UpdateOp <$> updateP -- <|> insertP) +parseDatabaseContextExprOp = DBUpdateOp <$> dbUpdatesP evalSQLInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> SQLCommand -> IO ConsoleResult evalSQLInteractive sessionId conn safeFlag interactiveConsole command = case command of - RODatabaseContextOp sel -> do + RODatabaseContextOp query -> do --get relvars to build conversion context - eDFExpr <- C.convertSQLSelect sessionId conn sel + eDFExpr <- C.convertSQLQuery sessionId conn query case eDFExpr of Left err -> pure $ DisplayRelationalErrorResult err Right dfExpr -> do @@ -62,8 +60,8 @@ evalSQLInteractive sessionId conn safeFlag interactiveConsole command = pure (DisplayErrorResult ("No such example: " <> exampleName)) DatabaseContextExprOp dbcExpr -> do eHandler $ C.executeDatabaseContextExpr sessionId conn dbcExpr - UpdateOp up -> do - eDBCExpr <- C.convertSQLUpdate sessionId conn up + DBUpdateOp updates -> do + eDBCExpr <- C.convertSQLDBUpdates sessionId conn updates case eDBCExpr of Left err -> pure $ DisplayRelationalErrorResult err Right dbcExpr -> diff --git a/src/bin/SQL/Interpreter/DBUpdate.hs b/src/bin/SQL/Interpreter/DBUpdate.hs new file mode 100644 index 00000000..33692b40 --- /dev/null +++ b/src/bin/SQL/Interpreter/DBUpdate.hs @@ -0,0 +1,17 @@ +module SQL.Interpreter.DBUpdate where +import ProjectM36.Interpreter +import ProjectM36.SQL.DBUpdate +import SQL.Interpreter.Update +import SQL.Interpreter.Insert +import SQL.Interpreter.Delete +import SQL.Interpreter.Base +import Text.Megaparsec + +dbUpdatesP :: Parser [DBUpdate] +dbUpdatesP = some dbUpdateP + +dbUpdateP :: Parser DBUpdate +dbUpdateP = (UpdateUpdate <$> updateP <* semi) <|> + (UpdateInsert <$> insertP <* semi) <|> + (UpdateDelete <$> deleteP <* semi) + diff --git a/src/bin/SQL/Interpreter/Delete.hs b/src/bin/SQL/Interpreter/Delete.hs new file mode 100644 index 00000000..d384faf8 --- /dev/null +++ b/src/bin/SQL/Interpreter/Delete.hs @@ -0,0 +1,15 @@ +module SQL.Interpreter.Delete where +import SQL.Interpreter.Select +import ProjectM36.SQL.Delete +import ProjectM36.SQL.Select +import SQL.Interpreter.Base +import ProjectM36.Interpreter +import Control.Applicative + +deleteP :: Parser Delete +deleteP = do + reserveds "delete from" + tname <- tableNameP + restrictExpr <- whereP <|> pure (RestrictionExpr (BooleanLiteral True)) + pure $ Delete { target = tname, + restriction = restrictExpr } diff --git a/src/bin/SQL/Interpreter/Insert.hs b/src/bin/SQL/Interpreter/Insert.hs new file mode 100644 index 00000000..71d9ebe3 --- /dev/null +++ b/src/bin/SQL/Interpreter/Insert.hs @@ -0,0 +1,15 @@ +module SQL.Interpreter.Insert where +import SQL.Interpreter.Select +import ProjectM36.SQL.Insert +import SQL.Interpreter.Base +import ProjectM36.Interpreter + +insertP :: Parser Insert +insertP = do + reserveds "insert into" + tname <- tableNameP + colNames <- parens (sepByComma1 unqualifiedColumnNameP) + q <- queryP + pure (Insert { target = tname, + targetColumns = colNames, + source = q }) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 69f8c5d9..1736a0f8 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -13,16 +13,28 @@ import qualified Data.List.NonEmpty as NE parseSelect :: Text -> Either ParserError Select -parseSelect = parse (queryExprP <* semi <* eof) "" +parseSelect = parse (selectP <* semi <* eof) "" + +parseQuery :: Text -> Either ParserError Query +parseQuery = parse (queryP <* semi <* eof) "" -queryExprP :: Parser Select -queryExprP = tableP <|> selectP +queryP :: Parser Query +queryP = (QuerySelect <$> selectP) <|> + (QueryValues <$> valuesP) <|> + (QueryTable <$> tableP) + +valuesP :: Parser [[ScalarExpr]] +valuesP = do + reserved "values" + sepByComma1 tupleP + +tupleP :: Parser [ScalarExpr] +tupleP = parens (sepByComma1 scalarExprP) -tableP :: Parser Select +tableP :: Parser TableName tableP = do reserved "table" - tname <- tableNameP - pure $ emptySelect { tableExpr = Just $ emptyTableExpr { fromClause = [SimpleTableRef tname] } } + tableNameP tableNameP :: Parser TableName tableNameP = TableName <$> qualifiedNameP' diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs index e6d4ab7e..9444a9e5 100644 --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -48,8 +48,8 @@ module ProjectM36.Client defaultHeadName, addClientNode, getDDLHash, - convertSQLSelect, - convertSQLUpdate, + convertSQLQuery, + convertSQLDBUpdates, PersistenceStrategy(..), RelationalExpr, RelationalExprBase(..), @@ -170,8 +170,8 @@ import qualified Network.RPC.Curryer.Server as RPC import Network.Socket (Socket, AddrInfo(..), getAddrInfo, defaultHints, AddrInfoFlag(..), SocketType(..), ServiceName, hostAddressToTuple, SockAddr(..)) import GHC.Conc (unsafeIOToSTM) import ProjectM36.SQL.Select as SQL -import ProjectM36.SQL.Update as SQL -import ProjectM36.SQL.Convert +import ProjectM36.SQL.DBUpdate as SQL +import ProjectM36.SQL.Convert type Hostname = String @@ -1100,9 +1100,9 @@ getDDLHash sessionId (InProcessConnection conf) = do pure (ddlHash ctx graph) getDDLHash sessionId conn@RemoteConnection{} = remoteCall conn (GetDDLHash sessionId) --- | Convert a SQL Select expression into a DataFrameExpr. Because the conversion process requires substantial database metadata access (such as retrieving types for various subexpressions), we cannot process SQL client-side. However, the underlying DBMS is completely unaware that the resultant DataFrameExpr has come from SQL. -convertSQLSelect :: SessionId -> Connection -> Select -> IO (Either RelationalError DF.DataFrameExpr) -convertSQLSelect sessionId (InProcessConnection conf) sel = do +-- | Convert a SQL Query expression into a DataFrameExpr. Because the conversion process requires substantial database metadata access (such as retrieving types for various subexpressions), we cannot process SQL client-side. However, the underlying DBMS is completely unaware that the resultant DataFrameExpr has come from SQL. +convertSQLQuery :: SessionId -> Connection -> Query -> IO (Either RelationalError DF.DataFrameExpr) +convertSQLQuery sessionId (InProcessConnection conf) query = do let sessions = ipSessions conf graphTvar = ipTransactionGraph conf atomically $ do @@ -1115,13 +1115,13 @@ convertSQLSelect sessionId (InProcessConnection conf) sel = do reEnv = RE.mkRelationalExprEnv ctx transGraph typeF = optimizeAndEvalRelationalExpr reEnv -- convert SQL data into DataFrameExpr - case evalConvertM mempty (convertSelect typeF sel) of + case evalConvertM mempty (convertQuery typeF query) of Left err -> pure (Left (SQLConversionError err)) Right dfExpr -> pure (Right dfExpr) -convertSQLSelect sessionId conn@RemoteConnection{} sel = remoteCall conn (ConvertSQLSelect sessionId sel) +convertSQLQuery sessionId conn@RemoteConnection{} q = remoteCall conn (ConvertSQLQuery sessionId q) -convertSQLUpdate :: SessionId -> Connection -> SQL.Update -> IO (Either RelationalError DatabaseContextExpr) -convertSQLUpdate sessionId (InProcessConnection conf) update = do +convertSQLDBUpdates :: SessionId -> Connection -> [SQL.DBUpdate] -> IO (Either RelationalError DatabaseContextExpr) +convertSQLDBUpdates sessionId (InProcessConnection conf) updates = do let sessions = ipSessions conf graphTvar = ipTransactionGraph conf atomically $ do @@ -1134,11 +1134,10 @@ convertSQLUpdate sessionId (InProcessConnection conf) update = do reEnv = RE.mkRelationalExprEnv ctx transGraph typeF = optimizeAndEvalRelationalExpr reEnv -- convert SQL data into DataFrameExpr - case evalConvertM mempty (convertUpdate typeF update) of + case evalConvertM mempty (convertDBUpdates typeF updates) of Left err -> pure (Left (SQLConversionError err)) Right updateExpr -> pure (Right updateExpr) -convertSQLUpdate sessionId conn@RemoteConnection{} up = remoteCall conn (ConvertSQLUpdate sessionId up) - +convertSQLDBUpdates sessionId conn@RemoteConnection{} ups = remoteCall conn (ConvertSQLUpdates sessionId ups) registeredQueriesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) registeredQueriesAsRelation sessionId (InProcessConnection conf) = do diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs index 4d190e15..a9d6ce8a 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -171,6 +171,7 @@ data SQLError = NotSupportedError T.Text | TableAliasMismatchError TableAlias | UnexpectedTableNameError TableName | UnexpectedColumnNameError ColumnName | + ColumnNamesMismatch (S.Set UnqualifiedColumnName) (S.Set UnqualifiedColumnName) | -- used for INSERT expressions ColumnResolutionError ColumnName | ColumnAliasResolutionError ColumnAlias | UnexpectedRelationalExprError RelationalExpr | diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index ba24c9d4..4bba7437 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -4,7 +4,10 @@ module ProjectM36.SQL.Convert where import ProjectM36.Base as B import ProjectM36.Error import ProjectM36.SQL.Select -import ProjectM36.SQL.Update as SQL +import ProjectM36.SQL.Insert as Insert +import ProjectM36.SQL.DBUpdate +import ProjectM36.SQL.Update as Update +import ProjectM36.SQL.Delete as Delete import ProjectM36.RelationalExpression import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A @@ -169,10 +172,10 @@ generateColumnAlias (TableAlias tAlias) attrName = do True _ -> False --some conflict, so loop firstAvailableName = find nameIsAvailable potentialNames - traceShowM ("generateColumnAlias scan"::String, tAlias, attrName, firstAvailableName) +-- traceShowM ("generateColumnAlias scan"::String, tAlias, attrName, firstAvailableName) case firstAvailableName of Just (ColumnName [nam]) -> pure (ColumnAlias nam) - _ -> throwSQLE (ColumnResolutionError (ColumnName [attrName])) + _ -> throwSQLE $ ColumnResolutionError (ColumnName [attrName]) -- | Insert another table into the TableContext. Returns an alias map of any columns which could conflict with column names already present in the TableContext so that they can be optionally renamed. insertTable :: TableAlias -> RelationalExpr -> Attributes -> ConvertM ColumnAliasMap @@ -466,7 +469,7 @@ attributeNameForColumnName colName = do ColumnName [_, col] | col `A.isAttributeNameContained` rvattrs -> -- the column has not been aliased, so we presume it can be use the column name directly pure col - _ -> throwSQLE $ ColumnResolutionError colName + _ -> throwSQLE $ traceShow ("attrnameforcolname"::String, rvattrs, colName) $ ColumnResolutionError colName {- attributeNameForColumnName :: ColumnName -> ConvertM AttributeName attributeNameForColumnName colName = do @@ -516,6 +519,27 @@ baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (Tupl orderExprs = [], offset = Nothing, limit = Nothing } + +falseDFExpr :: DataFrameExpr +falseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () []), --relationFalse + orderExprs = [], + offset = Nothing, + limit = Nothing } + + +convertQuery :: TypeForRelExprF -> Query -> ConvertM DataFrameExpr +convertQuery typeF (QuerySelect sel) = convertSelect typeF sel +convertQuery typeF (QueryValues vals) = do + let convertTupleExprs tupVals = do + TupleExpr . M.fromList <$> mapM (\(c, sexpr) -> do + atomExpr <- convertScalarExpr typeF sexpr + pure ("attr_" <> T.pack (show c), atomExpr) + ) (zip [1::Int ..] tupVals) + tupleExprs <- mapM convertTupleExprs vals + pure (baseDFExpr { convertExpr = MakeRelationFromExprs Nothing (TupleExprs () tupleExprs) }) +convertQuery typeF (QueryTable tname) = do + rvName <- convertTableName tname + pure $ baseDFExpr { convertExpr = RelationVariable rvName () } convertSelect :: TypeForRelExprF -> Select -> ConvertM DataFrameExpr convertSelect typeF sel = do @@ -1109,9 +1133,46 @@ convertUpdate typeF up = do restrictionExpr <- case mRestriction up of Nothing -> pure TruePredicate Just restriction -> convertWhereClause typeF restriction - rvname <- convertTableName (target up) + rvname <- convertTableName (Update.target up) pure (B.Update rvname atomMap restrictionExpr) convertTableName :: TableName -> ConvertM RelVarName convertTableName (TableName [tname]) = pure tname convertTableName t@TableName{} = throwSQLE (UnexpectedTableNameError t) + +convertDBUpdates :: TypeForRelExprF -> [DBUpdate] -> ConvertM DatabaseContextExpr +convertDBUpdates typeF dbUpdates = MultipleExpr <$> mapM (convertDBUpdate typeF) dbUpdates + +convertDBUpdate :: TypeForRelExprF -> DBUpdate -> ConvertM DatabaseContextExpr +convertDBUpdate typeF (UpdateUpdate up) = convertUpdate typeF up +convertDBUpdate typeF (UpdateInsert ins) = convertInsert typeF ins +convertDBUpdate typeF (UpdateDelete del) = convertDelete typeF del + +convertInsert :: TypeForRelExprF -> Insert -> ConvertM DatabaseContextExpr +convertInsert typeF ins = do + dfExpr <- convertQuery typeF (source ins) + when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") + -- check that all columns are mentioned because Project:M36 does not support default columns + case typeF (convertExpr dfExpr) of + Left err -> throwSQLE (SQLRelationalError err) + Right rvExprType -> do + let rvExprAttrNames = A.attributeNamesList (attributes rvExprType) + insAttrNames = map convertUnqualifiedColumnName (targetColumns ins) + rvExprColNameSet = S.map UnqualifiedColumnName (S.fromList rvExprAttrNames) + insAttrColSet = S.fromList (targetColumns ins) + when (length rvExprAttrNames /= length insAttrNames) $ throwSQLE (ColumnNamesMismatch rvExprColNameSet insAttrColSet) + rvTarget <- convertTableName (Insert.target ins) + -- rename attributes rexpr via query/values to map to targetCol attrs + let insExpr = Rename (S.fromList (zip rvExprAttrNames insAttrNames)) (convertExpr dfExpr) + pure $ B.Insert rvTarget insExpr + +convertDelete :: TypeForRelExprF -> Delete.Delete -> ConvertM DatabaseContextExpr +convertDelete typeF del = do + rvname <- convertTableName (Delete.target del) + let rv = RelationVariable rvname () + case typeF rv of + Left err -> throwSQLE (SQLRelationalError err) + Right typeRel -> do + insertTable (TableAlias rvname) rv (attributes typeRel) + res <- convertWhereClause typeF (restriction del) + pure (B.Delete rvname res) diff --git a/src/lib/ProjectM36/SQL/DBUpdate.hs b/src/lib/ProjectM36/SQL/DBUpdate.hs new file mode 100644 index 00000000..e0db1791 --- /dev/null +++ b/src/lib/ProjectM36/SQL/DBUpdate.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +module ProjectM36.SQL.DBUpdate where +import ProjectM36.SQL.Update +import ProjectM36.SQL.Insert +import ProjectM36.SQL.Delete +import Control.DeepSeq +import Codec.Winery +import GHC.Generics + +-- | represents any SQL expression which can change the current transaction state such as +data DBUpdate = UpdateUpdate Update | + UpdateInsert Insert | + UpdateDelete Delete + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant DBUpdate + + diff --git a/src/lib/ProjectM36/SQL/Delete.hs b/src/lib/ProjectM36/SQL/Delete.hs new file mode 100644 index 00000000..b2056767 --- /dev/null +++ b/src/lib/ProjectM36/SQL/Delete.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +module ProjectM36.SQL.Delete where +import ProjectM36.SQL.Select +import Control.DeepSeq +import Codec.Winery +import GHC.Generics + +data Delete = Delete { target :: TableName, + restriction :: RestrictionExpr + } + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryRecord Delete diff --git a/src/lib/ProjectM36/SQL/Insert.hs b/src/lib/ProjectM36/SQL/Insert.hs new file mode 100644 index 00000000..5ac6e42a --- /dev/null +++ b/src/lib/ProjectM36/SQL/Insert.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +module ProjectM36.SQL.Insert where +import ProjectM36.SQL.Select +import ProjectM36.Serialise.Base () +import Control.DeepSeq +import Codec.Winery +import GHC.Generics + +data Insert = Insert + { target :: TableName, + targetColumns :: [UnqualifiedColumnName], -- because ProjectM36 does not support default values in columns, all columns from the underlying table must be included here + source :: Query + } + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryRecord Insert + diff --git a/src/lib/ProjectM36/SQL/Select.hs b/src/lib/ProjectM36/SQL/Select.hs index e878d690..b3e06ab0 100644 --- a/src/lib/ProjectM36/SQL/Select.hs +++ b/src/lib/ProjectM36/SQL/Select.hs @@ -7,7 +7,12 @@ import Codec.Winery import GHC.Generics import Control.DeepSeq --- we use an intermediate data structure because it may need to be probed into order to create a proper relational expression +data Query = QuerySelect Select | + QueryValues [[ScalarExpr]] | + QueryTable TableName + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant Query + data Select = Select { distinctness :: Maybe Distinctness, projectionClause :: [SelectItem], tableExpr :: Maybe TableExpr, diff --git a/src/lib/ProjectM36/SQL/Update.hs b/src/lib/ProjectM36/SQL/Update.hs index 3eb071eb..297aa328 100644 --- a/src/lib/ProjectM36/SQL/Update.hs +++ b/src/lib/ProjectM36/SQL/Update.hs @@ -13,7 +13,7 @@ data Update = Update setColumns :: [(UnqualifiedColumnName, ScalarExpr)], --we don't support multi-column SET yet mRestriction :: Maybe RestrictionExpr } - --RETURNING not yet supported + --RETURNING not yet supported- how would we support this anyway- we must force the update to be materialized deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryRecord Update diff --git a/src/lib/ProjectM36/Server/EntryPoints.hs b/src/lib/ProjectM36/Server/EntryPoints.hs index 71b8311d..f0bbe238 100644 --- a/src/lib/ProjectM36/Server/EntryPoints.hs +++ b/src/lib/ProjectM36/Server/EntryPoints.hs @@ -4,7 +4,7 @@ import ProjectM36.Base hiding (inclusionDependencies) import ProjectM36.IsomorphicSchema import ProjectM36.HashSecurely import ProjectM36.SQL.Select -import ProjectM36.SQL.Update +import ProjectM36.SQL.DBUpdate import ProjectM36.Client as C import Data.Map import Control.Concurrent (threadDelay) @@ -160,8 +160,8 @@ handleRetrieveRegisteredQueries :: Maybe Timeout -> SessionId -> Connection -> I handleRetrieveRegisteredQueries ti sessionId conn = timeoutRelErr ti (C.registeredQueriesAsRelation sessionId conn) -handleConvertSQLSelect :: Maybe Timeout -> SessionId -> Connection -> Select -> IO (Either RelationalError DataFrameExpr) -handleConvertSQLSelect ti sessionId conn sel = timeoutRelErr ti (C.convertSQLSelect sessionId conn sel) +handleConvertSQLQuery :: Maybe Timeout -> SessionId -> Connection -> Query -> IO (Either RelationalError DataFrameExpr) +handleConvertSQLQuery ti sessionId conn sel = timeoutRelErr ti (C.convertSQLQuery sessionId conn sel) -handleConvertSQLUpdate :: Maybe Timeout -> SessionId -> Connection -> Update -> IO (Either RelationalError DatabaseContextExpr) -handleConvertSQLUpdate ti sessionId conn up = timeoutRelErr ti (C.convertSQLUpdate sessionId conn up) +handleConvertSQLUpdates :: Maybe Timeout -> SessionId -> Connection -> [DBUpdate] -> IO (Either RelationalError DatabaseContextExpr) +handleConvertSQLUpdates ti sessionId conn ups = timeoutRelErr ti (C.convertSQLDBUpdates sessionId conn ups) diff --git a/src/lib/ProjectM36/Server/RemoteCallTypes.hs b/src/lib/ProjectM36/Server/RemoteCallTypes.hs index 723d5642..37f300b5 100644 --- a/src/lib/ProjectM36/Server/RemoteCallTypes.hs +++ b/src/lib/ProjectM36/Server/RemoteCallTypes.hs @@ -9,7 +9,7 @@ import ProjectM36.Session import ProjectM36.Serialise.DataFrame () import ProjectM36.Serialise.IsomorphicSchema () import ProjectM36.SQL.Select -import ProjectM36.SQL.Update +import ProjectM36.SQL.DBUpdate import GHC.Generics import Codec.Winery @@ -113,8 +113,8 @@ data RetrieveDDLAsRelation = RetrieveDDLAsRelation SessionId data RetrieveRegisteredQueries = RetrieveRegisteredQueries SessionId RPCData(RetrieveRegisteredQueries) -data ConvertSQLSelect = ConvertSQLSelect SessionId Select - RPCData(ConvertSQLSelect) +data ConvertSQLQuery = ConvertSQLQuery SessionId Query + RPCData(ConvertSQLQuery) -data ConvertSQLUpdate = ConvertSQLUpdate SessionId Update - RPCData(ConvertSQLUpdate) +data ConvertSQLUpdates = ConvertSQLUpdates SessionId [DBUpdate] + RPCData(ConvertSQLUpdates) From 4d96d4793abb00e8203ced4ca8269148d72aa45b Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 12 Mar 2024 00:17:51 -0400 Subject: [PATCH 063/170] add CREATE TABLE with NULL/NOT NULL support fix all warnings on SQL conversion --- project-m36.cabal | 6 +- src/bin/SQL/Interpreter.hs | 2 +- src/bin/SQL/Interpreter/CreateTable.hs | 39 ++++++ src/bin/SQL/Interpreter/DBUpdate.hs | 4 +- src/lib/ProjectM36/Base.hs | 3 - src/lib/ProjectM36/Error.hs | 4 +- src/lib/ProjectM36/SQL/Convert.hs | 157 +++++++++++++++++-------- src/lib/ProjectM36/SQL/DBUpdate.hs | 4 +- 8 files changed, 161 insertions(+), 58 deletions(-) create mode 100644 src/bin/SQL/Interpreter/CreateTable.hs diff --git a/project-m36.cabal b/project-m36.cabal index 533eaec9..9aeaab68 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -142,7 +142,8 @@ Library ProjectM36.SQL.Update, ProjectM36.SQL.Insert, ProjectM36.SQL.Delete, - ProjectM36.SQL.DBUpdate + ProjectM36.SQL.DBUpdate, + ProjectM36.SQL.CreateTable GHC-Options: -Wall -rdynamic if os(windows) Build-Depends: Win32 >= 2.12 @@ -293,7 +294,8 @@ Executable sqlegacy SQL.Interpreter.Update, SQL.Interpreter.Insert, SQL.Interpreter.Delete, - SQL.Interpreter.DBUpdate + SQL.Interpreter.DBUpdate, + SQL.Interpreter.CreateTable Main-Is: ./SQL/Interpreter/sqlegacy.hs if os(windows) diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs index a48e9334..088ebcb3 100644 --- a/src/bin/SQL/Interpreter.hs +++ b/src/bin/SQL/Interpreter.hs @@ -17,7 +17,7 @@ import SQL.Interpreter.Base data SQLCommand = RODatabaseContextOp Query | -- SELECT DatabaseContextExprOp DatabaseContextExpr | - DBUpdateOp [DBUpdate] | -- INSERT, UPDATE, DELETE + DBUpdateOp [DBUpdate] | -- INSERT, UPDATE, DELETE, CREATE TABLE, DROP TABLE ImportBasicExampleOp ImportBasicExampleOperator | -- IMPORT EXAMPLE cjdate TransactionGraphOp TransactionGraphOperator -- COMMIT, ROLLBACK deriving (Show) diff --git a/src/bin/SQL/Interpreter/CreateTable.hs b/src/bin/SQL/Interpreter/CreateTable.hs new file mode 100644 index 00000000..7d515a78 --- /dev/null +++ b/src/bin/SQL/Interpreter/CreateTable.hs @@ -0,0 +1,39 @@ +module SQL.Interpreter.CreateTable where +import SQL.Interpreter.Select +import ProjectM36.SQL.Select +import ProjectM36.SQL.CreateTable +import SQL.Interpreter.Base +import ProjectM36.Interpreter +import Text.Megaparsec + +createTableP :: Parser CreateTable +createTableP = do + reserveds "create table" + tname <- tableNameP + colsAndTypes <- parens columnNamesAndTypesP + pure $ CreateTable { target = tname, + targetColumns = colsAndTypes + } + +columnNamesAndTypesP :: Parser [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)] +columnNamesAndTypesP = + sepByComma $ do + colName <- unqualifiedColumnNameP + colType <- columnTypeP + perColConstraints <- perColConstraintsP + pure (colName, colType, perColConstraints) + +columnTypeP :: Parser ColumnType +columnTypeP = choice (map (\(nam, typ) -> reserved nam *> pure typ) types) + where + types = [("integer", IntegerColumnType), + ("int", IntegerColumnType), + ("text", TextColumnType), + ("bool", BoolColumnType), + ("double", DoubleColumnType), + ("datetime", DateTimeColumnType)] + +perColConstraintsP :: Parser PerColumnConstraints +perColConstraintsP = do + let baseConstraints = PerColumnConstraints { notNullConstraint = False } + (try (reserveds "not null" *> pure (baseConstraints { notNullConstraint = True}))) <|> pure baseConstraints diff --git a/src/bin/SQL/Interpreter/DBUpdate.hs b/src/bin/SQL/Interpreter/DBUpdate.hs index 33692b40..60e7d95d 100644 --- a/src/bin/SQL/Interpreter/DBUpdate.hs +++ b/src/bin/SQL/Interpreter/DBUpdate.hs @@ -4,6 +4,7 @@ import ProjectM36.SQL.DBUpdate import SQL.Interpreter.Update import SQL.Interpreter.Insert import SQL.Interpreter.Delete +import SQL.Interpreter.CreateTable import SQL.Interpreter.Base import Text.Megaparsec @@ -13,5 +14,6 @@ dbUpdatesP = some dbUpdateP dbUpdateP :: Parser DBUpdate dbUpdateP = (UpdateUpdate <$> updateP <* semi) <|> (UpdateInsert <$> insertP <* semi) <|> - (UpdateDelete <$> deleteP <* semi) + (UpdateDelete <$> deleteP <* semi) <|> + (UpdateCreateTable <$> createTableP <* semi) diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index a9ce0a57..4672225e 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -105,9 +105,6 @@ data AtomType = IntAtomType | --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor deriving (Eq, NFData, Generic, Show, Read, Hashable) -instance Ord AtomType where - compare = undefined - -- this should probably be an ordered dictionary in order to be able to round-trip these arguments type TypeVarMap = M.Map TypeVarName AtomType diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs index a9d6ce8a..de0a021c 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -20,6 +20,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName) | TupleAttributeTypeMismatchError Attributes | AttributeCountMismatchError Int | AttributeNamesMismatchError (S.Set AttributeName) + | AttributeTypesMismatchError Attributes | AttributeNameInUseError AttributeName | AttributeIsNotRelationValuedError AttributeName | CouldNotInferAttributes @@ -176,7 +177,8 @@ data SQLError = NotSupportedError T.Text | ColumnAliasResolutionError ColumnAlias | UnexpectedRelationalExprError RelationalExpr | UnexpectedAsteriskError ColumnProjectionName | + UnexpectedColumnProjectionName ColumnProjectionName | AmbiguousColumnResolutionError ColumnName | DuplicateColumnAliasError ColumnAlias | - SQLRelationalError RelationalError + SQLRelationalError RelationalError deriving (Show, Eq, Generic, Typeable, NFData) diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 4bba7437..50c2341e 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -3,11 +3,13 @@ module ProjectM36.SQL.Convert where import ProjectM36.Base as B import ProjectM36.Error +import ProjectM36.DataTypes.SQL.Null import ProjectM36.SQL.Select import ProjectM36.SQL.Insert as Insert import ProjectM36.SQL.DBUpdate import ProjectM36.SQL.Update as Update import ProjectM36.SQL.Delete as Delete +import ProjectM36.SQL.CreateTable as CreateTable import ProjectM36.RelationalExpression import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A @@ -36,6 +38,7 @@ TODO * remove commented out code * remove unused functions from failed experiments * remove traceShow* +* enable duplicate rows by adding uuid column -} --over the course of conversion of a table expression, we collect all the table aliases we encounter, including non-aliased table references, including the type of the table, projections have their own name resolution system @@ -150,6 +153,7 @@ withSubSelect m = do -- we are aware of the table, but there may have been some new columns added Just (_,_,colAliasRemapper') -> pure (acc <> foldr (convertColAliases colAliasRemapper') mempty (M.toList colAliasRemapper')) + tableDiffFolder _ (_, (rvexpr, _, _)) = throwSQLE (UnexpectedRelationalExprError rvexpr) diff <- foldM tableDiffFolder mempty (M.toList postSub) @@ -253,7 +257,7 @@ noteColumnMention mTblAlias colName mColAlias = do Nothing -> do -- lookup without table alias -- unqualified column alias- search for unambiguous table reference - let folder (ta@(TableAlias tAlias), (_, _, colAliasRemapper)) acc = + let folder (ta, (_, _, colAliasRemapper)) acc = case attributeNameForAttributeAlias colAlias colAliasRemapper of Left _ -> acc Right attrName -> (ta,attrName) : acc @@ -274,7 +278,7 @@ noteColumnMention mTblAlias colName mColAlias = do pure (ColumnAlias colAlias) (_:_) -> -- two many matches, error throwSQLE (AmbiguousColumnResolutionError colName) - + other@ColumnName{} -> throwSQLE (UnexpectedColumnNameError other) ------ @@ -391,11 +395,11 @@ findColumn' targetCol (TableContext tMap) = do -- search ColumnAliasRemapper for columns which have already been noted- can be used for probing for new aliases findNotedColumn' :: ColumnName -> TableContext -> Either SQLError [(TableAlias, AttributeName)] -findNotedColumn' cn@(ColumnName [attr]) (TableContext tcontext) = +findNotedColumn' (ColumnName [attr]) (TableContext tcontext) = -- search all column alias remappers for attribute- if there is a conflict because the alias is ambiguous, error out pure $ foldr folder mempty (M.toList tcontext) where - folder (ta@(TableAlias tAlias), (_, _, colAliasRemapper)) acc = + folder (ta, (_, _, colAliasRemapper)) acc = case attributeNameForAttributeAlias attr colAliasRemapper of Left _ -> acc Right attrName -> (ta,attrName) : acc @@ -408,14 +412,15 @@ findNotedColumn' (ColumnName [tPrefix, attr]) (TableContext tcontext) = Just (_, _, colAlRemapper) -> do attrName <- attributeNameForAttributeAlias attr colAlRemapper pure [(TableAlias tPrefix, attrName)] +findNotedColumn' colName _ = Left $ UnexpectedColumnNameError colName attributeNameForAttributeAlias :: AttributeAlias -> ColumnAliasRemapper -> Either SQLError AttributeName attributeNameForAttributeAlias al remapper = do -- traceShowM ("attributeNameForAttributeAlias"::String, al, remapper) - foldr folder (Left (ColumnAliasResolutionError (ColumnAlias "GONKTASTIC"))) (M.toList remapper) + foldr folder (Left (ColumnAliasResolutionError (ColumnAlias al))) (M.toList remapper) where - folder (attrName, (attrAlias, _)) acc = + folder (_attrName, (attrAlias, _)) acc = if attrAlias == al then pure attrAlias else @@ -444,9 +449,9 @@ attributeNameForColumnName colName = do tcontext@(TableContext tmap) <- get let (_, rvattrs, colAliases) = tmap M.! tKey --strip table prefix, if necessary - colAlias@(ColumnAlias colAttr) <- case colName of + (ColumnAlias colAttr) <- case colName of ColumnName [attr] -> pure $ ColumnAlias attr - ColumnName [tname,attr] -> pure $ ColumnAlias attr + ColumnName [_tname,attr] -> pure $ ColumnAlias attr ColumnName{} -> throwSQLE $ ColumnResolutionError colName -- traceShowM ("attributeNameForColumnName' colAlias"::String, colAttr, colAliases, colAlias) case M.lookup colAttr colAliases of @@ -463,6 +468,7 @@ attributeNameForColumnName colName = do (ColumnAlias al) <- noteColumnMention (Just tKey) (ColumnName [tAlias,colAttr]) Nothing --traceShowM ("attributeNameForColumnName' noteColumnMention"::String, colAttr, al) pure al + Left err -> throwSQLE err --pure (T.concat [tAlias, ".", colAttr]) else case colName of @@ -537,7 +543,7 @@ convertQuery typeF (QueryValues vals) = do ) (zip [1::Int ..] tupVals) tupleExprs <- mapM convertTupleExprs vals pure (baseDFExpr { convertExpr = MakeRelationFromExprs Nothing (TupleExprs () tupleExprs) }) -convertQuery typeF (QueryTable tname) = do +convertQuery _typeF (QueryTable tname) = do rvName <- convertTableName tname pure $ baseDFExpr { convertExpr = RelationVariable rvName () } @@ -587,7 +593,7 @@ convertSubSelect typeF sel = do Just wClause -> do convertWithClause typeF wClause let typeF' = appendWithsToTypeF typeF wExprs - (dfExpr, colMap) <- case tableExpr sel of + (dfExpr, _colMap) <- case tableExpr sel of Nothing -> pure (baseDFExpr, mempty) Just tExpr -> convertTableExpr typeF' tExpr when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") @@ -650,6 +656,7 @@ convertSelectItem typeF acc (c,selItem) = where colinfo (ColumnProjectionName [ProjectionName name]) = do findOneColumn (ColumnName [name]) + colinfo colProjName = throwSQLE $ UnexpectedColumnProjectionName colProjName convertProjection :: TypeForRelExprF -> [SelectItem] -> ConvertM (RelationalExpr -> RelationalExpr) convertProjection typeF selItems = do @@ -670,6 +677,7 @@ convertProjection typeF selItems = do pure $ (S.insert (T.concat [nameA, ".", nameB]) attrNames, b) projFolder (attrNames, relExprAttributes) (ColumnProjectionName [ProjectionName tname, Asterisk]) = pure $ (attrNames, relExprAttributes <> [tname]) + projFolder _ colProjName = throwSQLE $ UnexpectedColumnProjectionName colProjName (attrNames, relExprRvs) <- foldM projFolder mempty (S.toList (taskProjections task)) let attrsProj = A.some (map (\rv -> RelationalExprAttributeNames (RelationVariable rv ())) relExprRvs <> [AttributeNames attrNames]) pure $ Project attrsProj @@ -705,7 +713,7 @@ convertTableExpr typeF tExpr = do restrictPredExpr <- convertWhereClause typeF whereExpr pure $ Restrict restrictPredExpr Nothing -> pure id - orderExprs <- convertOrderByClause typeF (orderByClause tExpr) + orderExprs' <- convertOrderByClause typeF (orderByClause tExpr) -- add disambiguation renaming let disambiguationRenamerF = if S.null renames then id else Rename renames renames = S.fromList $ foldr folder mempty (M.toList columnMap) @@ -718,7 +726,7 @@ convertTableExpr typeF tExpr = do acc let dfExpr = DataFrameExpr { convertExpr = whereF (disambiguationRenamerF fromExpr), - orderExprs = orderExprs, + orderExprs = orderExprs', offset = offsetClause tExpr, limit = limitClause tExpr } pure (dfExpr, columnMap) @@ -726,48 +734,56 @@ convertTableExpr typeF tExpr = do convertWhereClause :: TypeForRelExprF -> RestrictionExpr -> ConvertM RestrictionPredicateExpr convertWhereClause typeF (RestrictionExpr rexpr) = do let wrongType t = throwSQLE $ TypeMismatchError t BoolAtomType --must be boolean expression - attrName' (ColumnName ts) = T.intercalate "." ts - coalesceBool expr = FunctionAtomExpr "sql_coalesce_bool" [expr] () + coalesceBoolF expr = FunctionAtomExpr "sql_coalesce_bool" [expr] () case rexpr of IntegerLiteral{} -> wrongType IntegerAtomType DoubleLiteral{} -> wrongType DoubleAtomType + NullLiteral{} -> wrongType IntegerAtomType StringLiteral{} -> wrongType TextAtomType - Identifier i -> wrongType TextAtomType -- could be a better error here - BinaryOperator i@(Identifier colName) (OperatorName ["="]) exprMatch -> do --we don't know here if this results in a boolean expression, so we pass it down + Identifier _i -> wrongType TextAtomType -- could be a better error here + BooleanLiteral True -> + pure TruePredicate + BooleanLiteral False -> + pure (NotPredicate TruePredicate) + BinaryOperator (Identifier colName) (OperatorName ["="]) exprMatch -> do --we don't know here if this results in a boolean expression, so we pass it down attrName <- attributeNameForColumnName colName -- traceShowM ("convertWhereClause eq"::String, colName, attrName) -- traceStateM expr' <- convertScalarExpr typeF exprMatch - pure (AtomExprPredicate (coalesceBool (FunctionAtomExpr "sql_equals" [AttributeAtomExpr attrName, expr'] ()))) + pure (AtomExprPredicate (coalesceBoolF (FunctionAtomExpr "sql_equals" [AttributeAtomExpr attrName, expr'] ()))) BinaryOperator exprA op exprB -> do a <- convertScalarExpr typeF exprA b <- convertScalarExpr typeF exprB f <- lookupOperator op - pure (AtomExprPredicate (coalesceBool (f [a,b]))) + pure (AtomExprPredicate (coalesceBoolF (f [a,b]))) PostfixOperator expr (OperatorName ops) -> do expr' <- convertScalarExpr typeF expr -- traceShowM ("convertWhereClause"::String, expr') case ops of ["is", "null"] -> do - pure $ AtomExprPredicate (coalesceBool (FunctionAtomExpr "sql_isnull" [expr'] ())) + pure $ AtomExprPredicate (coalesceBoolF (FunctionAtomExpr "sql_isnull" [expr'] ())) + other -> throwSQLE $ NotSupportedError ("postfix operator: " <> T.pack (show other)) InExpr inOrNotIn sexpr (InList matches') -> do eqExpr <- convertScalarExpr typeF sexpr - let (match:matches) = reverse matches' - firstItem <- convertScalarExpr typeF match - let inFunc a b = AtomExprPredicate (FunctionAtomExpr "eq" [a,b] ()) - predExpr' = inFunc eqExpr firstItem - folder predExpr'' sexprItem = do - item <- convertScalarExpr typeF sexprItem - pure $ OrPredicate (inFunc eqExpr item) predExpr'' - res <- foldM folder predExpr' matches --be careful here once we introduce NULLs - case inOrNotIn of - In -> pure res - NotIn -> pure (NotPredicate res) + case reverse matches' of + (match:matches) -> do + firstItem <- convertScalarExpr typeF match + let inFunc a b = AtomExprPredicate (FunctionAtomExpr "sql_equals" [a,b] ()) + predExpr' = inFunc eqExpr firstItem + folder predExpr'' sexprItem = do + item <- convertScalarExpr typeF sexprItem + pure $ OrPredicate (inFunc eqExpr item) predExpr'' + res <- foldM folder predExpr' matches --be careful here once we introduce NULLs + case inOrNotIn of + In -> pure res + NotIn -> pure (NotPredicate res) + [] -> throwSQLE $ NotSupportedError "empty IN() clause" ExistsExpr subQ -> do relExpr <- convertSubSelect typeF subQ --pretty sure I have to rename attributes in both the top-level query and in this one to prevent attribute conflicts- we can't rename all the attributes in the subquery, because the renamer won't know which attributes actually refer to the top-level attributes- should we just prefix all attributes unconditionally or send a signal upstream to rename attributes? FIXME - let rexpr = Project A.empty relExpr - pure (RelationalExprPredicate rexpr) + let rexpr' = Project A.empty relExpr + pure (RelationalExprPredicate rexpr') + other -> throwSQLE $ NotSupportedError ("where clause: " <> T.pack (show other)) convertScalarExpr :: TypeForRelExprF -> ScalarExpr -> ConvertM AtomExpr @@ -788,6 +804,7 @@ convertScalarExpr typeF expr = do b <- convertScalarExpr typeF exprB f <- lookupOperator op pure $ f [a,b] + other -> throwSQLE $ NotSupportedError ("scalar expr: " <> T.pack (show other)) convertProjectionScalarExpr :: TypeForRelExprF -> ProjectionScalarExpr -> ConvertM AtomExpr convertProjectionScalarExpr typeF expr = do @@ -806,6 +823,7 @@ convertProjectionScalarExpr typeF expr = do b <- convertProjectionScalarExpr typeF exprB f <- lookupOperator op pure $ f [a,b] + other -> throwSQLE $ NotSupportedError ("projection scalar expr: " <> T.pack (show other)) convertOrderByClause :: TypeForRelExprF -> [SortExpr] -> ConvertM [AttributeOrderExpr] convertOrderByClause typeF exprs = @@ -849,36 +867,39 @@ convertFromClause typeF (firstRef:trefs) = do typeR <- wrapTypeF typeF rv colMap <- insertTable al rv (attributes typeR) pure (RelationVariable alias (), colMap) + convertFirstTableRef tref = + throwSQLE $ NotSupportedError ("first table ref: " <> T.pack (show tref)) (firstRel, colMap) <- convertFirstTableRef firstRef expr' <- foldM (joinTableRef typeF) firstRel (zip [1..] trefs) pure (expr', colMap) +convertFromClause _ [] = throwSQLE $ NotSupportedError "empty table refs" -- | Convert TableRefs after the first one (assumes all additional TableRefs are for joins). Returns the qualified name key that was added to the map, the underlying relexpr (not aliased so that it can used for extracting type information), and the new table context map convertTableRef :: TypeForRelExprF -> TableRef -> ConvertM (TableAlias, RelationalExpr) convertTableRef typeF tref = case tref of - SimpleTableRef qn@(TableName [nam]) -> do + SimpleTableRef (TableName [nam]) -> do let rv = RelationVariable nam () ta = TableAlias nam typeRel <- wrapTypeF typeF rv - tContext' <- insertTable ta rv (attributes typeRel) + _ <- insertTable ta rv (attributes typeRel) pure (ta, rv) -- include with clause even for simple cases because we use this mapping to - AliasedTableRef (SimpleTableRef qn@(TableName [nam])) tAlias -> do + AliasedTableRef (SimpleTableRef (TableName [nam])) tAlias -> do typeRel <- wrapTypeF typeF (RelationVariable nam ()) let rv = RelationVariable nam () - tContext' <- insertTable tAlias rv (attributes typeRel) + _ <- insertTable tAlias rv (attributes typeRel) pure $ (tAlias, RelationVariable nam ()) - x -> throwSQLE $ NotSupportedError (T.pack (show x)) + x -> throwSQLE $ NotSupportedError ("table ref: " <> T.pack (show x)) joinTableRef :: TypeForRelExprF -> RelationalExpr -> (Int, TableRef) -> ConvertM RelationalExpr -joinTableRef typeF rvA (c,tref) = do +joinTableRef typeF rvA (_c,tref) = do -- optionally prefix attributes unelss the expr is a RelationVariable let attrRenamer x expr attrs = do renamed <- mapM (renameOneAttr x expr) attrs pure (Rename (S.fromList renamed) expr) -- prefix all attributes - prefixRenamer tAlias@(TableAlias prefix) expr attrs = do + prefixRenamer tAlias expr attrs = do renamed <- mapM (prefixOneAttr tAlias) attrs pure (Rename (S.fromList renamed) expr) prefixOneAttr tAlias@(TableAlias tPrefix) old_name = do @@ -904,7 +925,7 @@ joinTableRef typeF rvA (c,tref) = do crossJoin jtref = do --rename all columns to prefix them with a generated alias to prevent any natural join occurring, then perform normal join -- we need the type to get all the attribute names for both relexprs - (tKey, rvB) <- convertTableRef typeF jtref + (_tKey, rvB) <- convertTableRef typeF jtref case typeF rvA of Left err -> throwSQLE (SQLRelationalError err) Right typeA -> @@ -928,7 +949,7 @@ joinTableRef typeF rvA (c,tref) = do InnerJoinTableRef jtref (JoinUsing qnames) -> do (tKey, rvB) <- convertTableRef typeF jtref let jCondAttrs = S.fromList $ map convertUnqualifiedColumnName qnames - (attrsIntersection, attrsA, attrsB) <- commonAttributeNames typeF rvA rvB + (attrsIntersection, _attrsA, _attrsB) <- commonAttributeNames typeF rvA rvB --rename attributes used in the join condition let attrsToRename = S.difference attrsIntersection jCondAttrs -- traceShowM ("inner", attrsToRename, attrsIntersection, jCondAttrs) @@ -949,7 +970,7 @@ joinTableRef typeF rvA (c,tref) = do --extract all table aliases to create a remapping for SQL names discovered in the sexpr withExpr <- With <$> tableAliasesAsWithNameAssocs - (commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF (withExpr rvA) (withExpr rvB) + (_commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF (withExpr rvA) (withExpr rvB) -- first, execute the rename, renaming all attributes according to their table aliases let rvPrefix rvExpr = case rvExpr of @@ -965,7 +986,6 @@ joinTableRef typeF rvA (c,tref) = do -- traceShowM ("exprA", exprA) -- traceShowM ("exprB", exprB) -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition - tcontext <- get joinRe <- convertScalarExpr typeF joinExpr --' why are we renaming here- can't we call attributenameforcolumnname in the scalarexpr conversion??? --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name = --rename all common attrs and use the new names in the join condition @@ -981,6 +1001,7 @@ joinTableRef typeF rvA (c,tref) = do joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA)))) + other -> throwSQLE $ NotSupportedError ("join: " <> T.pack (show other)) lookupOperator :: OperatorName -> ConvertM ([AtomExpr] -> AtomExpr) lookupOperator (OperatorName nam) = lookupFunc (FuncName nam) @@ -993,6 +1014,7 @@ lookupFunc qname = case lookup nam sqlFuncs of Nothing -> throwSQLE $ NoSuchSQLFunctionError qname Just match -> pure match + other -> throwSQLE $ NotSupportedError ("function name: " <> T.pack (show other)) where f n args = FunctionAtomExpr n args () sqlFuncs = [(">",f "sql_gt"), @@ -1058,7 +1080,7 @@ needsToRenameAllAttributes (RestrictionExpr sexpr) = BetweenOperator e1 _ e2 -> rec' e1 || rec' e2 FunctionApplication _ e1 -> rec' e1 CaseExpr cases else' -> or (map (\(whens, then') -> - or (map rec' whens) || rec' then') cases) + or (map rec' whens) || rec' then' || maybe False rec' else') cases) QuantifiedComparison{} -> True InExpr _ sexpr'' _ -> rec' sexpr'' BooleanOperatorExpr e1 _ e2 -> rec' e1 || rec' e2 @@ -1132,7 +1154,7 @@ convertUpdate typeF up = do atomMap <- M.fromList <$> mapM convertSetColumns (setColumns up) restrictionExpr <- case mRestriction up of Nothing -> pure TruePredicate - Just restriction -> convertWhereClause typeF restriction + Just restriction' -> convertWhereClause typeF restriction' rvname <- convertTableName (Update.target up) pure (B.Update rvname atomMap restrictionExpr) @@ -1147,6 +1169,7 @@ convertDBUpdate :: TypeForRelExprF -> DBUpdate -> ConvertM DatabaseContextExpr convertDBUpdate typeF (UpdateUpdate up) = convertUpdate typeF up convertDBUpdate typeF (UpdateInsert ins) = convertInsert typeF ins convertDBUpdate typeF (UpdateDelete del) = convertDelete typeF del +convertDBUpdate typeF (UpdateCreateTable ct) = convertCreateTable typeF ct convertInsert :: TypeForRelExprF -> Insert -> ConvertM DatabaseContextExpr convertInsert typeF ins = do @@ -1157,13 +1180,19 @@ convertInsert typeF ins = do Left err -> throwSQLE (SQLRelationalError err) Right rvExprType -> do let rvExprAttrNames = A.attributeNamesList (attributes rvExprType) - insAttrNames = map convertUnqualifiedColumnName (targetColumns ins) + insAttrNames = map convertUnqualifiedColumnName (Insert.targetColumns ins) rvExprColNameSet = S.map UnqualifiedColumnName (S.fromList rvExprAttrNames) - insAttrColSet = S.fromList (targetColumns ins) + insAttrColSet = S.fromList (Insert.targetColumns ins) when (length rvExprAttrNames /= length insAttrNames) $ throwSQLE (ColumnNamesMismatch rvExprColNameSet insAttrColSet) rvTarget <- convertTableName (Insert.target ins) + -- insert into s(s#,sname,city,status) select * from s; -- we need to reorder attributes to align? -- rename attributes rexpr via query/values to map to targetCol attrs - let insExpr = Rename (S.fromList (zip rvExprAttrNames insAttrNames)) (convertExpr dfExpr) + let insExpr = if rvExprColNameSet == insAttrColSet then -- if the attributes already align, don't perform any renaming + convertExpr dfExpr + else + Rename (S.fromList (filter rendundantRename (zip rvExprAttrNames insAttrNames))) (convertExpr dfExpr) + rendundantRename (a,b) = a /= b + traceShowM ("ins"::String, insExpr) pure $ B.Insert rvTarget insExpr convertDelete :: TypeForRelExprF -> Delete.Delete -> ConvertM DatabaseContextExpr @@ -1173,6 +1202,36 @@ convertDelete typeF del = do case typeF rv of Left err -> throwSQLE (SQLRelationalError err) Right typeRel -> do - insertTable (TableAlias rvname) rv (attributes typeRel) + _ <- insertTable (TableAlias rvname) rv (attributes typeRel) res <- convertWhereClause typeF (restriction del) pure (B.Delete rvname res) + +convertCreateTable :: TypeForRelExprF -> CreateTable -> ConvertM DatabaseContextExpr +convertCreateTable _typeF ct = do + rvTarget <- convertTableName (CreateTable.target ct) + attrs <- convertColumnNamesAndTypes (CreateTable.targetColumns ct) + pure (Define rvTarget attrs) + +convertColumnNamesAndTypes :: [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)] -> ConvertM [AttributeExpr] +convertColumnNamesAndTypes colAssocs = + mapM mkAttributeExpr colAssocs + where + mkAttributeExpr (UnqualifiedColumnName colName, colType, constraints) = do + aType <- convertColumnType colType constraints + pure $ NakedAttributeExpr (Attribute colName aType) + +convertColumnType :: ColumnType -> PerColumnConstraints -> ConvertM AtomType +convertColumnType colType constraints = + mkAtomType $ + case colType of + IntegerColumnType -> IntegerAtomType + TextColumnType -> TextAtomType + BoolColumnType -> BoolAtomType + DoubleColumnType -> DoubleAtomType + DateTimeColumnType -> DateTimeAtomType + where + mkAtomType aType = + pure $ if notNullConstraint constraints then + aType + else + nullAtomType aType diff --git a/src/lib/ProjectM36/SQL/DBUpdate.hs b/src/lib/ProjectM36/SQL/DBUpdate.hs index e0db1791..eab000e9 100644 --- a/src/lib/ProjectM36/SQL/DBUpdate.hs +++ b/src/lib/ProjectM36/SQL/DBUpdate.hs @@ -3,6 +3,7 @@ module ProjectM36.SQL.DBUpdate where import ProjectM36.SQL.Update import ProjectM36.SQL.Insert import ProjectM36.SQL.Delete +import ProjectM36.SQL.CreateTable import Control.DeepSeq import Codec.Winery import GHC.Generics @@ -10,7 +11,8 @@ import GHC.Generics -- | represents any SQL expression which can change the current transaction state such as data DBUpdate = UpdateUpdate Update | UpdateInsert Insert | - UpdateDelete Delete + UpdateDelete Delete | + UpdateCreateTable CreateTable deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant DBUpdate From f691f6d886b0d11f1f363587d4e0f57cc5abd683 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 12 Mar 2024 00:18:12 -0400 Subject: [PATCH 064/170] improve error message in mismatched attributes in relational union --- src/lib/ProjectM36/Relation.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/lib/ProjectM36/Relation.hs b/src/lib/ProjectM36/Relation.hs index 14ba69f1..e87d26ad 100644 --- a/src/lib/ProjectM36/Relation.hs +++ b/src/lib/ProjectM36/Relation.hs @@ -81,8 +81,10 @@ singletonTuple rel@(Relation _ tupleSet) = if cardinality rel == Finite 1 then -- this is still unncessarily expensive for (bigx union bigx) because each tuple is hashed and compared for equality (when the hashes match), but the major expense is attributesEqual, but we already know that all tuple attributes are equal (it's a precondition) union :: Relation -> Relation -> Either RelationalError Relation union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = - if not (A.attributesEqual attrs1 attrs2) - then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2)) + if not (A.attributeNameSet attrs1 == A.attributeNameSet attrs2) then + Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2)) + else if not (A.attributesEqual attrs1 attrs2) then + Left $ AttributeTypesMismatchError $ A.attributesDifference attrs1 attrs2 else Right $ Relation attrs1 newtuples where From 91de746366637cc29a5fb9c462559b5538a3f4c0 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 12 Mar 2024 00:18:35 -0400 Subject: [PATCH 065/170] fix missing server handlers for new SQL client/server conversion functions --- src/lib/ProjectM36/Server.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/lib/ProjectM36/Server.hs b/src/lib/ProjectM36/Server.hs index 576b65df..701973ec 100644 --- a/src/lib/ProjectM36/Server.hs +++ b/src/lib/ProjectM36/Server.hs @@ -112,7 +112,13 @@ requestHandlers testFlag ti = handleRetrieveDDLAsRelation ti sessionId conn), RequestHandler (\sState (RetrieveRegisteredQueries sessionId) -> do conn <- getConn sState - handleRetrieveRegisteredQueries ti sessionId conn) + handleRetrieveRegisteredQueries ti sessionId conn), + RequestHandler (\sState (ConvertSQLQuery sessionId q) -> do + conn <- getConn sState + handleConvertSQLQuery ti sessionId conn q), + RequestHandler (\sState (ConvertSQLUpdates sessionId updates) -> do + conn <- getConn sState + handleConvertSQLUpdates ti sessionId conn updates) ] ++ if testFlag then testModeHandlers ti else [] getConn :: ConnectionState ServerState -> IO Connection From 7653dfd7265f154d7c4d6c201c744fc861f65c82 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 12 Mar 2024 00:19:28 -0400 Subject: [PATCH 066/170] add missing createTable definition --- src/lib/ProjectM36/SQL/CreateTable.hs | 29 +++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 src/lib/ProjectM36/SQL/CreateTable.hs diff --git a/src/lib/ProjectM36/SQL/CreateTable.hs b/src/lib/ProjectM36/SQL/CreateTable.hs new file mode 100644 index 00000000..157372ff --- /dev/null +++ b/src/lib/ProjectM36/SQL/CreateTable.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +module ProjectM36.SQL.CreateTable where +import ProjectM36.SQL.Select +import Control.DeepSeq +import Codec.Winery +import GHC.Generics + +data CreateTable = CreateTable + { target :: TableName, + targetColumns :: [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)] + } + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryRecord CreateTable + +data ColumnType = + IntegerColumnType | + TextColumnType | + BoolColumnType | + DoubleColumnType | + DateTimeColumnType + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant ColumnType + +-- | Used to represent constraints which are defined next to a column name and type. +data PerColumnConstraints = PerColumnConstraints { + notNullConstraint :: Bool + } + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant PerColumnConstraints From f7976ddd1ae300c6575313f6003cb2a53ba52529 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 13 Mar 2024 01:03:17 -0400 Subject: [PATCH 067/170] add support for drop table sql add display for equivalent tutoriald migration/learning assistant --- project-m36.cabal | 7 +++- src/bin/ProjectM36/Interpreter.hs | 4 ++ src/bin/SQL/Interpreter.hs | 12 ++++-- src/bin/SQL/Interpreter/DBUpdate.hs | 4 +- src/bin/SQL/Interpreter/DropTable.hs | 10 +++++ src/bin/TutorialD/Printer.hs | 55 ++++++++++++++++++++++++++++ src/lib/ProjectM36/SQL/Convert.hs | 7 ++++ src/lib/ProjectM36/SQL/DBUpdate.hs | 4 +- src/lib/ProjectM36/SQL/DropTable.hs | 14 +++++++ 9 files changed, 109 insertions(+), 8 deletions(-) create mode 100644 src/bin/SQL/Interpreter/DropTable.hs create mode 100644 src/lib/ProjectM36/SQL/DropTable.hs diff --git a/project-m36.cabal b/project-m36.cabal index 9aeaab68..3095b0b8 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -143,7 +143,8 @@ Library ProjectM36.SQL.Insert, ProjectM36.SQL.Delete, ProjectM36.SQL.DBUpdate, - ProjectM36.SQL.CreateTable + ProjectM36.SQL.CreateTable, + ProjectM36.SQL.DropTable GHC-Options: -Wall -rdynamic if os(windows) Build-Depends: Win32 >= 2.12 @@ -295,7 +296,9 @@ Executable sqlegacy SQL.Interpreter.Insert, SQL.Interpreter.Delete, SQL.Interpreter.DBUpdate, - SQL.Interpreter.CreateTable + SQL.Interpreter.CreateTable, + SQL.Interpreter.DropTable, + TutorialD.Printer Main-Is: ./SQL/Interpreter/sqlegacy.hs if os(windows) diff --git a/src/bin/ProjectM36/Interpreter.hs b/src/bin/ProjectM36/Interpreter.hs index 53892032..0725dae7 100644 --- a/src/bin/ProjectM36/Interpreter.hs +++ b/src/bin/ProjectM36/Interpreter.hs @@ -27,6 +27,7 @@ data ConsoleResult = QuitResult | DisplayIOResult (IO ()) | DisplayRelationResult Relation | DisplayDataFrameResult DataFrame | + DisplayHintWith Text ConsoleResult | DisplayErrorResult StringType | DisplayRelationalErrorResult RelationalError | DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text @@ -55,3 +56,6 @@ displayResult (DisplayParseErrorResult mPromptLength err) = do displayResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame) displayResult (DisplayRelationalErrorResult err) = TIO.putStrLn ("ERR:" <> T.pack (show err)) +displayResult (DisplayHintWith hint result) = do + displayResult (DisplayResult hint) + displayResult result diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs index 088ebcb3..1e077e83 100644 --- a/src/bin/SQL/Interpreter.hs +++ b/src/bin/SQL/Interpreter.hs @@ -5,6 +5,7 @@ import ProjectM36.SQL.Select import ProjectM36.DatabaseContext import ProjectM36.DateExamples import ProjectM36.Error +import TutorialD.Printer import SQL.Interpreter.ImportBasicExample import SQL.Interpreter.TransactionGraphOperator import SQL.Interpreter.Select @@ -49,23 +50,26 @@ evalSQLInteractive sessionId conn safeFlag interactiveConsole command = case eDFExpr of Left err -> pure $ DisplayRelationalErrorResult err Right dfExpr -> do + let hint = renderPretty dfExpr eDF <- C.executeDataFrameExpr sessionId conn dfExpr case eDF of Left err -> pure $ DisplayRelationalErrorResult err - Right df -> pure $ DisplayDataFrameResult df + Right df -> pure $ DisplayHintWith ("[Equivalent TutorialD] " <> hint) (DisplayDataFrameResult df) ImportBasicExampleOp (ImportBasicExampleOperator exampleName) -> do if exampleName == "cjdate" then evalSQLInteractive sessionId conn safeFlag interactiveConsole (DatabaseContextExprOp (databaseContextAsDatabaseContextExpr dateExamples)) else pure (DisplayErrorResult ("No such example: " <> exampleName)) DatabaseContextExprOp dbcExpr -> do - eHandler $ C.executeDatabaseContextExpr sessionId conn dbcExpr + eHandler $ C.executeDatabaseContextExpr sessionId conn dbcExpr DBUpdateOp updates -> do eDBCExpr <- C.convertSQLDBUpdates sessionId conn updates case eDBCExpr of Left err -> pure $ DisplayRelationalErrorResult err - Right dbcExpr -> - evalSQLInteractive sessionId conn safeFlag interactiveConsole (DatabaseContextExprOp dbcExpr) + Right dbcExpr -> do + let hint = renderPretty dbcExpr + _ <- eHandler $ C.executeDatabaseContextExpr sessionId conn dbcExpr + pure $ DisplayHintWith ("Equivalent TutorialD: " <> hint) QuietSuccessResult TransactionGraphOp Commit -> do eHandler $ C.commit sessionId conn TransactionGraphOp Rollback -> do diff --git a/src/bin/SQL/Interpreter/DBUpdate.hs b/src/bin/SQL/Interpreter/DBUpdate.hs index 60e7d95d..1a562d57 100644 --- a/src/bin/SQL/Interpreter/DBUpdate.hs +++ b/src/bin/SQL/Interpreter/DBUpdate.hs @@ -5,6 +5,7 @@ import SQL.Interpreter.Update import SQL.Interpreter.Insert import SQL.Interpreter.Delete import SQL.Interpreter.CreateTable +import SQL.Interpreter.DropTable import SQL.Interpreter.Base import Text.Megaparsec @@ -15,5 +16,6 @@ dbUpdateP :: Parser DBUpdate dbUpdateP = (UpdateUpdate <$> updateP <* semi) <|> (UpdateInsert <$> insertP <* semi) <|> (UpdateDelete <$> deleteP <* semi) <|> - (UpdateCreateTable <$> createTableP <* semi) + (UpdateCreateTable <$> createTableP <* semi) <|> + (UpdateDropTable <$> dropTableP <* semi) diff --git a/src/bin/SQL/Interpreter/DropTable.hs b/src/bin/SQL/Interpreter/DropTable.hs new file mode 100644 index 00000000..e492a54b --- /dev/null +++ b/src/bin/SQL/Interpreter/DropTable.hs @@ -0,0 +1,10 @@ +module SQL.Interpreter.DropTable where +import ProjectM36.SQL.DropTable +import SQL.Interpreter.Select +import SQL.Interpreter.Base +import ProjectM36.Interpreter + +dropTableP :: Parser DropTable +dropTableP = do + reserveds "drop table" + DropTable <$> tableNameP diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index 2680d717..2df9c456 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -8,6 +8,7 @@ import ProjectM36.Base import ProjectM36.Attribute as A hiding (null) import ProjectM36.DataFrame import Prettyprinter +import Prettyprinter.Render.Text import qualified Data.Set as S hiding (fromList) import qualified Data.Vector as V import qualified Data.Map.Strict as M @@ -16,6 +17,10 @@ import Data.Time.Clock.POSIX import qualified Data.ByteString.Base64 as B64 import qualified Data.Text.Encoding as TE import Data.UUID hiding (null) +import Data.Text (Text) + +renderPretty :: Pretty a => a -> Text +renderPretty = renderStrict . layoutPretty defaultLayoutOptions . pretty instance Pretty Atom where pretty (IntegerAtom x) = pretty x @@ -193,6 +198,56 @@ instance Pretty Order where pretty AscendingOrder = "ascending" pretty DescendingOrder = "descending" +instance Pretty DatabaseContextExpr where + pretty expr = + case expr of + NoOperation -> mempty + Define rvname attrExprs -> pretty rvname <+> "::" <+> bracesList (map pretty attrExprs) + Undefine rvname -> "undefine" <+> pretty rvname + Assign rvname relExpr -> pretty rvname <+> ":=" <+> pretty relExpr + Insert rvname relExpr -> "insert" <+> pretty rvname <+> pretty relExpr + Delete rvname restExpr -> "delete" <+> pretty rvname <+> "where" <+> pretty restExpr + Update rvname attrAtomMap restExpr -> "update" <+> pretty rvname <+> "where" <+> pretty restExpr <+> pretty attrAtomMap + AddInclusionDependency idName (InclusionDependency idA idB) -> + "constraint" <+> pretty idName <+> pretty idA <+> "in" <+> pretty idB + RemoveInclusionDependency idName -> "deleteconstraint" <+> pretty idName + AddNotification notName trigger old new -> + "notify" <+> pretty notName <+> pretty trigger <+> pretty old <+> pretty new + RemoveNotification notName -> + "unnotify" <+> pretty notName + AddTypeConstructor tConsDef dConss -> + "data" <+> pretty tConsDef <+> "=" <+> group (encloseSep "" "" "| " (pretty <$> dConss)) + RemoveTypeConstructor tConsName -> + "undata" <+> pretty tConsName + RemoveAtomFunction fname -> + "removeatomfunction" <+> pretty fname + RemoveDatabaseContextFunction fname -> + "removedatabasecontextfunction" <+> pretty fname + ExecuteDatabaseContextFunction fname atomExprs -> + "execute" <+> pretty fname <> prettyParensList atomExprs + AddRegisteredQuery rQName relExpr -> + "registerquery" <+> pretty rQName <+> pretty relExpr + RemoveRegisteredQuery rQName -> + "unregisterquery" <+> pretty rQName + MultipleExpr dbcExprs -> + group (encloseSep "" "" "; " (pretty <$> dbcExprs)) + +instance Pretty AttributeNameAtomExprMap where + pretty m = + group (encloseSep "(" ")" "," (map (\(attrName, atomExpr) -> pretty attrName <+> ":=" <+> pretty atomExpr) (M.toList m))) + +instance Pretty TypeConstructorDef where + pretty (ADTypeConstructorDef tConsName tVarNames) = pretty tConsName <+> hsep (pretty <$> tVarNames) + pretty (PrimitiveTypeConstructorDef tConsName _atomType') = pretty tConsName + +instance Pretty DataConstructorDef where + pretty (DataConstructorDef dConsName []) = pretty dConsName + pretty (DataConstructorDef dConsName args) = "(" <+> pretty dConsName <+> hsep (pretty <$> args) <+> ")" + +instance Pretty DataConstructorDefArg where + pretty (DataConstructorDefTypeConstructorArg tCons) = pretty tCons + pretty (DataConstructorDefTypeVarNameArg tVar) = pretty tVar + bracesList :: [Doc ann] -> Doc ann bracesList = group . encloseSep (flatAlt "{ " "{") (flatAlt " }" "}") ", " diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 50c2341e..0523640b 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -10,6 +10,7 @@ import ProjectM36.SQL.DBUpdate import ProjectM36.SQL.Update as Update import ProjectM36.SQL.Delete as Delete import ProjectM36.SQL.CreateTable as CreateTable +import ProjectM36.SQL.DropTable as DropTable import ProjectM36.RelationalExpression import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A @@ -1170,6 +1171,7 @@ convertDBUpdate typeF (UpdateUpdate up) = convertUpdate typeF up convertDBUpdate typeF (UpdateInsert ins) = convertInsert typeF ins convertDBUpdate typeF (UpdateDelete del) = convertDelete typeF del convertDBUpdate typeF (UpdateCreateTable ct) = convertCreateTable typeF ct +convertDBUpdate typeF (UpdateDropTable dt) = convertDropTable typeF dt convertInsert :: TypeForRelExprF -> Insert -> ConvertM DatabaseContextExpr convertInsert typeF ins = do @@ -1212,6 +1214,11 @@ convertCreateTable _typeF ct = do attrs <- convertColumnNamesAndTypes (CreateTable.targetColumns ct) pure (Define rvTarget attrs) +convertDropTable :: TypeForRelExprF -> DropTable -> ConvertM DatabaseContextExpr +convertDropTable _typeF dt = do + rvTarget <- convertTableName (DropTable.target dt) + pure (Undefine rvTarget) + convertColumnNamesAndTypes :: [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)] -> ConvertM [AttributeExpr] convertColumnNamesAndTypes colAssocs = mapM mkAttributeExpr colAssocs diff --git a/src/lib/ProjectM36/SQL/DBUpdate.hs b/src/lib/ProjectM36/SQL/DBUpdate.hs index eab000e9..74e144a8 100644 --- a/src/lib/ProjectM36/SQL/DBUpdate.hs +++ b/src/lib/ProjectM36/SQL/DBUpdate.hs @@ -4,6 +4,7 @@ import ProjectM36.SQL.Update import ProjectM36.SQL.Insert import ProjectM36.SQL.Delete import ProjectM36.SQL.CreateTable +import ProjectM36.SQL.DropTable import Control.DeepSeq import Codec.Winery import GHC.Generics @@ -12,7 +13,8 @@ import GHC.Generics data DBUpdate = UpdateUpdate Update | UpdateInsert Insert | UpdateDelete Delete | - UpdateCreateTable CreateTable + UpdateCreateTable CreateTable | + UpdateDropTable DropTable deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant DBUpdate diff --git a/src/lib/ProjectM36/SQL/DropTable.hs b/src/lib/ProjectM36/SQL/DropTable.hs new file mode 100644 index 00000000..27a609a2 --- /dev/null +++ b/src/lib/ProjectM36/SQL/DropTable.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +module ProjectM36.SQL.DropTable where +import ProjectM36.SQL.Select +import Control.DeepSeq +import Codec.Winery +import GHC.Generics + +data DropTable = DropTable + { target :: TableName } + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryRecord DropTable + + + From 6ce47c15c60bd2f83e98d0f8f778248b37a6cf53 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 13 Mar 2024 01:31:31 -0400 Subject: [PATCH 068/170] fix examples and websocket server compilation errors --- examples/Plantfarm.hs | 3 +- examples/blog.hs | 9 +++--- examples/hair.hs | 3 +- examples/out_of_the_tarpit.hs | 3 +- .../ProjectM36/Server/RemoteCallTypes/Json.hs | 28 +++++++++++++++++++ src/bin/ProjectM36/Server/WebSocket.hs | 11 ++++++-- src/bin/benchmark/Handles.hs | 8 ++++-- 7 files changed, 53 insertions(+), 12 deletions(-) diff --git a/examples/Plantfarm.hs b/examples/Plantfarm.hs index 2f219efb..e4e23943 100644 --- a/examples/Plantfarm.hs +++ b/examples/Plantfarm.hs @@ -17,6 +17,7 @@ import Data.Text as T (Text) import qualified Data.Text.Lazy as TL (pack) import GHC.Generics (Generic) import qualified ProjectM36.Base as Base +import ProjectM36.DatabaseContext import ProjectM36.Client ( AtomExprBase(NakedAtomExpr) , Atomable(toAddTypeExpr, toAtom) @@ -354,7 +355,7 @@ insertSampleData (DB sid conn) = do dbConnection :: IO DBConnection dbConnection = do -- connect to the database - let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] + let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext -- The code below persists the data in a DB with the name "base". \\ -- let connInfo = InProcessConnectionInfo (CrashSafePersistence "base") emptyNotificationCallback [] \\ -- In addition minimal persistance is available. \\ diff --git a/examples/blog.hs b/examples/blog.hs index 9e8900c9..ff24e180 100644 --- a/examples/blog.hs +++ b/examples/blog.hs @@ -7,6 +7,7 @@ import ProjectM36.Relation import ProjectM36.Tupleable import ProjectM36.Atom (relationForAtom) import ProjectM36.Tuple (atomForAttributeName) +import ProjectM36.DatabaseContext import Data.Either import GHC.Generics @@ -76,7 +77,7 @@ handleIOErrors m = do main :: IO () main = do --connect to the database - let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] + let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext conn <- handleIOError $ connectProjectM36 connInfo sessionId <- handleIOError $ createSessionAtHead conn "master" @@ -154,7 +155,7 @@ render500 msg = do --display one blog post along with its comments showBlogEntry :: SessionId -> Connection -> ActionM () showBlogEntry sessionId conn = do - blogid <- param "blogid" + blogid <- pathParam "blogid" --query the database to return the blog entry with a relation-valued attribute of the associated comments let blogRestrictionExpr = AttributeEqualityPredicate "title" (NakedAtomExpr (TextAtom blogid)) extendExpr = AttributeExtendTupleExpr "comments" (RelationAtomExpr commentsRestriction) @@ -204,8 +205,8 @@ showBlogEntry sessionId conn = do --add a comment to a blog post addComment :: SessionId -> Connection -> ActionM () addComment sessionId conn = do - blogid <- param "blogid" - commentText <- param "contents" + blogid <- pathParam "blogid" + commentText <- formParam "contents" now <- liftIO getCurrentTime case toInsertExpr [Comment {blogTitle = blogid, diff --git a/examples/hair.hs b/examples/hair.hs index 59d9b965..86ca038a 100644 --- a/examples/hair.hs +++ b/examples/hair.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings, DerivingVia #-} import ProjectM36.Client import ProjectM36.Relation.Show.Term +import ProjectM36.DatabaseContext import GHC.Generics import Data.Text import Control.DeepSeq @@ -16,7 +17,7 @@ data Hair = Bald | Brown | Blond | OtherColor Text main :: IO () main = do --connect to the database - let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] + let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext eCheck v = do x <- v case x of diff --git a/examples/out_of_the_tarpit.hs b/examples/out_of_the_tarpit.hs index e1cc7c15..c36a09bc 100644 --- a/examples/out_of_the_tarpit.hs +++ b/examples/out_of_the_tarpit.hs @@ -3,6 +3,7 @@ import ProjectM36.Client import ProjectM36.DataTypes.Primitive import ProjectM36.Tupleable +import ProjectM36.DatabaseContext import ProjectM36.Relation import ProjectM36.Error import Data.Either @@ -39,7 +40,7 @@ data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand main :: IO () main = do --connect to the database - let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] + let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext check x = case x of Left err -> error (show err) Right x' -> x' diff --git a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs index 1799931b..df140aa9 100644 --- a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +++ b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs @@ -12,6 +12,7 @@ import ProjectM36.IsomorphicSchema import ProjectM36.Server.RemoteCallTypes import ProjectM36.MerkleHash import ProjectM36.Attribute as A +import ProjectM36.SQL.Select import Data.Aeson import Data.ByteString.Base64 as B64 @@ -172,6 +173,33 @@ instance FromJSON Attributes where instance ToJSON RelationalError instance FromJSON RelationalError +instance ToJSON SQLError +instance FromJSON SQLError + +instance ToJSON ColumnProjectionName +instance FromJSON ColumnProjectionName + +instance ToJSON UnqualifiedColumnName +instance FromJSON UnqualifiedColumnName + +instance ToJSON ProjectionName +instance FromJSON ProjectionName + +instance ToJSON ColumnAlias +instance FromJSON ColumnAlias + +instance ToJSON ColumnName +instance FromJSON ColumnName + +instance ToJSON TableName +instance FromJSON TableName + +instance ToJSON TableAlias +instance FromJSON TableAlias + +instance ToJSON FuncName +instance FromJSON FuncName + instance ToJSON SchemaError instance FromJSON SchemaError diff --git a/src/bin/ProjectM36/Server/WebSocket.hs b/src/bin/ProjectM36/Server/WebSocket.hs index 21b84513..1f6b264e 100644 --- a/src/bin/ProjectM36/Server/WebSocket.hs +++ b/src/bin/ProjectM36/Server/WebSocket.hs @@ -15,7 +15,7 @@ import ProjectM36.Relation.Show.Term import ProjectM36.Relation.Show.HTML import Data.Aeson import TutorialD.Interpreter -import TutorialD.Interpreter.Base (TutorialDOperatorResult(..)) +import ProjectM36.Interpreter (ConsoleResult(..), SafeEvaluationFlag(..)) import ProjectM36.Client import Control.Exception import Data.Attoparsec.Text @@ -91,7 +91,7 @@ createConnection wsconn dbname port host = connectProjectM36 (RemoteConnectionIn sendError :: (ToJSON a) => WS.Connection -> a -> IO () sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err])) -handleOpResult :: WS.Connection -> Connection -> Presentation -> TutorialDOperatorResult -> IO () +handleOpResult :: WS.Connection -> Connection -> Presentation -> ConsoleResult -> IO () handleOpResult conn db _ QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db handleOpResult conn _ _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out])) handleOpResult _ _ _ (DisplayIOResult ioout) = ioout @@ -112,6 +112,13 @@ handleOpResult conn _ presentation (DisplayDataFrameResult df) = do texto = ["text" .= showDataFrame df | textPresentation presentation] htmlo = ["html" .= dataFrameAsHTML df | htmlPresentation presentation] WS.sendTextData conn (encode (object ["displaydataframe" .= object (jsono ++ texto ++ htmlo)])) +handleOpResult conn _ _ (DisplayRelationalErrorResult relErr) = + WS.sendTextData conn (encode (object ["displayrelationalerrorresult" .= relErr])) +handleOpResult conn dbconn presentation (DisplayHintWith txt conResult) = do + -- we should wrap this up into one response instead of two responses for clarity + WS.sendTextData conn (encode (object ["hint" .= txt])) + handleOpResult conn dbconn presentation conResult + -- get current schema and head name for client promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName) diff --git a/src/bin/benchmark/Handles.hs b/src/bin/benchmark/Handles.hs index b8e0b963..4d3fc149 100644 --- a/src/bin/benchmark/Handles.hs +++ b/src/bin/benchmark/Handles.hs @@ -4,7 +4,9 @@ import ProjectM36.Client import ProjectM36.Persist import Options.Applicative import TutorialD.Interpreter -import TutorialD.Interpreter.Base hiding (Parser, option) +import ProjectM36.Interpreter hiding (Parser) +import ProjectM36.DatabaseContext +import TutorialD.Interpreter.Base hiding (option) import qualified Data.Text as T #if __GLASGOW_HASKELL__ < 804 import Data.Monoid @@ -48,8 +50,8 @@ main = do runOpenClose :: T.Text -> T.Text -> Int -> FilePath -> IO () runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do - let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir') emptyNotificationCallback [] - eConn <- connectProjectM36 connInfo + let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir') emptyNotificationCallback [] basicDatabaseContext + eConn <- connectProjectM36 connInfo case eConn of Left err -> error (show err) Right conn -> do From 85741915670e58dad41245ad092330872bdc37e2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 14 Mar 2024 01:10:03 -0400 Subject: [PATCH 069/170] fix assorted build issues --- project-m36.cabal | 19 ++++++++++++------- src/lib/ProjectM36/Client.hs | 4 +++- stack.ghc9.2.yaml | 3 +++ stack.ghc9.4.yaml | 5 ++++- test/Client/Simple.hs | 6 +++--- test/MultiProcessDatabaseAccess.hs | 4 ++-- test/SQL/InterpreterTest.hs | 11 +++-------- test/TransactionGraph/Automerge.hs | 4 +++- test/TransactionGraph/Persist.hs | 2 +- test/TutorialD/Interpreter/TestBase.hs | 26 +++++++++++++++++++++++++- test/TutorialD/InterpreterTest.hs | 7 ++++++- 11 files changed, 65 insertions(+), 26 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index 3095b0b8..37a1ca08 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -358,7 +358,8 @@ Executable bigrel Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RelationalExpr, - TutorialD.Interpreter.Types + TutorialD.Interpreter.Types, + ProjectM36.Interpreter main-is: benchmark/bigrel.hs GHC-Options: -Wall -threaded -rtsopts HS-Source-Dirs: ./src/bin @@ -399,7 +400,7 @@ Test-Suite test-sql import: commontest type: exitcode-stdio-1.0 main-is: SQL/InterpreterTest.hs - Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, SQL.Interpreter.Convert, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator + Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator TutorialD.Printer Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific, recursion-schemes @@ -501,7 +502,7 @@ Executable Example-OutOfTheTarpit Executable Example-Blog Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty, blaze-html, http-types, winery + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty >= 0.22, blaze-html, http-types, winery Main-Is: examples/blog.hs GHC-Options: -Wall -threaded @@ -515,7 +516,7 @@ Executable Example-Hair Executable Example-Plantfarm Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: aeson, barbies, base, containers, deepseq, hashable, project-m36, random, scotty, text, winery + Build-Depends: aeson, barbies, base, containers, deepseq, hashable, project-m36, random, scotty >= 0.22, text, winery Main-Is: examples/Plantfarm.hs GHC-Options: -Wall -threaded @@ -546,7 +547,7 @@ Executable project-m36-websocket-server Default-Language: Haskell2010 Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls, scientific Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs - Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer + Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter GHC-Options: -Wall -threaded Hs-Source-Dirs: ./src/bin Default-Extensions: OverloadedStrings @@ -612,7 +613,8 @@ Executable handles TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, - TutorialD.Printer + TutorialD.Printer, + ProjectM36.Interpreter GHC-Options: -Wall -threaded -rtsopts HS-Source-Dirs: ./src/bin if flag(profiler) @@ -622,4 +624,7 @@ Test-Suite test-dataframe import: commontest type: exitcode-stdio-1.0 Main-Is: DataFrame.hs - Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer + Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer, ProjectM36.Interpreter + + + diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs index 9444a9e5..4268c22c 100644 --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -107,12 +107,14 @@ module ProjectM36.Client TupleExprsBase(..), AtomExprBase(..), RestrictionPredicateExprBase(..), - withTransaction + withTransaction, + basicDatabaseContext ) where import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well import qualified ProjectM36.Base as B import ProjectM36.Serialise.Error () import ProjectM36.Error +import ProjectM36.DatabaseContext import ProjectM36.Atomable import ProjectM36.AtomFunction as AF import ProjectM36.StaticOptimizer diff --git a/stack.ghc9.2.yaml b/stack.ghc9.2.yaml index b1cc4c6d..92b64d88 100644 --- a/stack.ghc9.2.yaml +++ b/stack.ghc9.2.yaml @@ -15,6 +15,9 @@ extra-deps: - unicode-data-0.2.0 - stm-containers-1.2 - stm-hamt-1.2.0.7 + - scotty-0.22 + - wai-extra-3.1.14 + - wai-3.2.4 flags: project-m36: diff --git a/stack.ghc9.4.yaml b/stack.ghc9.4.yaml index a59c8769..3655a136 100644 --- a/stack.ghc9.4.yaml +++ b/stack.ghc9.4.yaml @@ -15,7 +15,10 @@ extra-deps: - unicode-data-0.2.0 - stm-containers-1.2 - stm-hamt-1.2.0.7 - + - scotty-0.22 + - wai-extra-3.1.14 + - wai-3.2.4 + flags: project-m36: stack: true diff --git a/test/Client/Simple.hs b/test/Client/Simple.hs index 7a397b81..306160d5 100644 --- a/test/Client/Simple.hs +++ b/test/Client/Simple.hs @@ -29,7 +29,7 @@ assertEither x = do testSimpleCommitSuccess :: Test testSimpleCommitSuccess = TestCase $ withSystemTempDirectory "m36tempdb" $ \tempdir -> do - let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir "db")) emptyNotificationCallback [] + let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir "db")) emptyNotificationCallback [] basicDatabaseContext relExpr = Union (RelationVariable "x" ()) (RelationVariable "y" ()) dbconn <- assertEither (simpleConnectProjectM36 connInfo) @@ -52,7 +52,7 @@ testSimpleCommitFailure :: Test testSimpleCommitFailure = TestCase $ do let failAttrs = attributesFromList [Attribute "fail" IntAtomType] err <- withSystemTempDirectory "m36tempdb" $ \tempdir -> do - let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir "db")) emptyNotificationCallback [] + let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir "db")) emptyNotificationCallback [] basicDatabaseContext dbconn <- assertEither (simpleConnectProjectM36 connInfo) withTransaction dbconn $ do execute $ Assign "x" (ExistingRelation relationTrue) @@ -64,7 +64,7 @@ testSimpleCommitFailure = TestCase $ do -- #176 default merge couldn't handle Update testSimpleUpdate :: Test testSimpleUpdate = TestCase $ do - let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] + let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext dbconn <- assertEither (simpleConnectProjectM36 connInfo) assertEither $ withTransaction dbconn $ execute $ databaseContextAsDatabaseContextExpr dateExamples diff --git a/test/MultiProcessDatabaseAccess.hs b/test/MultiProcessDatabaseAccess.hs index 0ca1dcb7..da7c8eab 100644 --- a/test/MultiProcessDatabaseAccess.hs +++ b/test/MultiProcessDatabaseAccess.hs @@ -24,7 +24,7 @@ testList = TestList [testMultipleProcessAccess] testMultipleProcessAccess :: Test testMultipleProcessAccess = TestCase $ withSystemTempDirectory "pm36" $ \tmpdir -> do - let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback [] + let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback [] basicDatabaseContext master = "master" dudExpr = Assign "x" (RelationVariable "true" ()) dbdir = tmpdir "db" @@ -42,4 +42,4 @@ testMultipleProcessAccess = TestCase $ Left err -> assertFailure ("headTransactionId failed: " ++ show err) >> undefined Right x -> pure x res <- commit session2 conn2 - assertEqual "commit should fail" (Left (TransactionIsNotAHeadError headId)) res \ No newline at end of file + assertEqual "commit should fail" (Left (TransactionIsNotAHeadError headId)) res diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index b13a364c..7888cc72 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -1,9 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} import SQL.Interpreter.Select -import SQL.Interpreter.Convert ---import TutorialD.Interpreter.RelationalExpr +import ProjectM36.SQL.Convert +import ProjectM36.SQL.Select import TutorialD.Interpreter.RODatabaseContextOperator ---import TutorialD.Printer import ProjectM36.DataTypes.SQL.Null import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph @@ -135,10 +134,6 @@ testSelect = TestCase $ do ("SELECT * FROM sp JOIN s ON s.s# = sp.s# AND s.s# = sp.s#", "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_and(sql_equals(@`s.s#`,@`sp.s#`),sql_equals(@`s.s#`,@`sp.s#`)))}) where join_1=True) {all but join_1})", "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_and(sql_equals(@`s.s#`,@`sp.s#`),sql_equals(@`s.s#`,@`sp.s#`)))}) where join_1=True) {all but join_1})"), - -- TABLE - ("TABLE s", - "(s)", - "(s)"), -- any, all, some -- IN() ("SELECT * FROM s WHERE s# IN ('S1','S2')", @@ -232,7 +227,7 @@ testSelect = TestCase $ do check (sql, equivalent_tutd, confirmation_tutd) = do print sql --parse SQL - select <- case parse (queryExprP <* eof) "test" sql of + select <- case parse (selectP <* eof) "test" sql of Left err -> assertFailure (errorBundlePretty err) Right x -> do --print ("parsed SQL:"::String, x) diff --git a/test/TransactionGraph/Automerge.hs b/test/TransactionGraph/Automerge.hs index a425a383..d2d71031 100644 --- a/test/TransactionGraph/Automerge.hs +++ b/test/TransactionGraph/Automerge.hs @@ -1,5 +1,7 @@ import Test.HUnit import ProjectM36.Client +import ProjectM36.Interpreter +import ProjectM36.DatabaseContext import ProjectM36.Relation import qualified Data.Set as S import TutorialD.Interpreter.TestBase @@ -78,7 +80,7 @@ testAutomergeFailure = TestCase $ do testAutomergeReconnect :: Test testAutomergeReconnect = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do let repro = do - conn <- unsafeLeftCrash =<< connectProjectM36 (InProcessConnectionInfo (CrashSafePersistence (tempdir "test.db")) emptyNotificationCallback []) + conn <- unsafeLeftCrash =<< connectProjectM36 (InProcessConnectionInfo (CrashSafePersistence (tempdir "test.db")) emptyNotificationCallback [] basicDatabaseContext) sess <- unsafeLeftCrash =<< createSessionAtHead conn "master" autoMergeToHead sess conn UnionMergeStrategy "master" -- commit sess conn diff --git a/test/TransactionGraph/Persist.hs b/test/TransactionGraph/Persist.hs index 4f60264a..70d177ec 100644 --- a/test/TransactionGraph/Persist.hs +++ b/test/TransactionGraph/Persist.hs @@ -80,7 +80,7 @@ testMerkleHashValidation = TestCase $ -- add a commit and validate the hashes successfully withSystemTempDirectory "m36testdb" $ \tempdir -> do let dbdir = tempdir "dbdir" - connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback [] + connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback [] basicDatabaseContext conn <- assertIOEither $ connectProjectM36 connInfo sess <- assertIOEither $ createSessionAtHead conn "master" Right _ <- executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) diff --git a/test/TutorialD/Interpreter/TestBase.hs b/test/TutorialD/Interpreter/TestBase.hs index 8751d85a..ec6adeaf 100644 --- a/test/TutorialD/Interpreter/TestBase.hs +++ b/test/TutorialD/Interpreter/TestBase.hs @@ -1,5 +1,7 @@ module TutorialD.Interpreter.TestBase where import ProjectM36.Client +import ProjectM36.Interpreter +import ProjectM36.DatabaseContext import TutorialD.Interpreter import TutorialD.Interpreter.Base import ProjectM36.DateExamples @@ -9,7 +11,7 @@ import Data.Text dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection) dateExamplesConnection callback = do - dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback []) + dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback [] basicDatabaseContext) case dbconn of Left err -> error (show err) Right conn -> do @@ -36,6 +38,8 @@ executeTutorialD sessionId conn tutd = case parseTutorialD tutd of DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?" DisplayErrorResult err -> assertFailure (show tutd ++ ": " ++ show err) QuietSuccessResult -> pure () + DisplayRelationalErrorResult err -> assertFailure ("DisplayRelationalErrorResult: " <> show err) + DisplayHintWith _ _ -> pure () expectTutorialDErr :: SessionId -> Connection -> (Text -> Bool) -> Text -> IO () expectTutorialDErr sessionId conn matchFunc tutd = case parseTutorialD tutd of @@ -51,6 +55,26 @@ expectTutorialDErr sessionId conn matchFunc tutd = case parseTutorialD tutd of DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?" DisplayErrorResult err -> assertBool (unpack tutd ++ " match error on: " ++ unpack err) (matchFunc err) QuietSuccessResult -> pure () + DisplayRelationalErrorResult err -> assertFailure ("DisplayRelationalErrorResult: " <> show err) + DisplayHintWith{} -> pure () + +expectTutorialDRelationalError :: SessionId -> Connection -> RelationalError -> Text -> IO () +expectTutorialDRelationalError sessionId conn matchErr tutd = case parseTutorialD tutd of + Left err -> assertFailure (show tutd ++ ": " ++ show err) + Right parsed -> do + result <- evalTutorialD sessionId conn UnsafeEvaluation parsed + case result of + QuitResult -> assertFailure "quit?" + DisplayResult _ -> assertFailure "display?" + DisplayIOResult _ -> assertFailure "displayIO?" + DisplayRelationResult _ -> assertFailure "displayrelation?" + DisplayDataFrameResult _ -> assertFailure "displaydataframe?" + DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?" + DisplayErrorResult err -> assertFailure (unpack err) + QuietSuccessResult -> assertFailure "quietsuccess?" + DisplayRelationalErrorResult err -> assertEqual "relational error" matchErr err + DisplayHintWith{} -> assertFailure "displayhintwith?" + eitherFail :: Either RelationalError a -> IO () eitherFail (Left err) = assertFailure (show err) diff --git a/test/TutorialD/InterpreterTest.hs b/test/TutorialD/InterpreterTest.hs index ca096e03..cfd172f2 100644 --- a/test/TutorialD/InterpreterTest.hs +++ b/test/TutorialD/InterpreterTest.hs @@ -19,6 +19,7 @@ import ProjectM36.Base hiding (Finite) import ProjectM36.TransactionGraph import ProjectM36.Client import ProjectM36.HashSecurely +import ProjectM36.Interpreter import qualified ProjectM36.DisconnectedTransaction as Discon import qualified ProjectM36.AttributeNames as AN import qualified ProjectM36.Session as Sess @@ -250,6 +251,8 @@ transactionGraphAddCommitTest = TestCase $ do discon <- disconnectedTransaction_ sessionId dbconn let context = Discon.concreteDatabaseContext discon assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just (ExistingRelation suppliersRel)) + DisplayRelationalErrorResult err -> assertFailure (show err) + DisplayHintWith{} -> assertFailure "displayhintwith?" transactionRollbackTest :: Test transactionRollbackTest = TestCase $ do @@ -615,7 +618,9 @@ testRelationAttributeDefinition = TestCase $ do let expected = mkRelationFromList attrs [[RelationAtom subRel]] attrs = attributesFromList [Attribute "a" (RelationAtomType subRelAttrs)] subRelAttrs = attributesFromList [Attribute "b" IntegerAtomType] - Right subRel = mkRelationFromList subRelAttrs [[IntegerAtom 4]] + subRel = case mkRelationFromList subRelAttrs [[IntegerAtom 4]] of + Left err -> error (show err) + Right rel -> rel assertEqual "relation attribute construction" expected eX -- test rejected subrelation construction due to floating type variables expectTutorialDErr sessionId dbconn (T.isPrefixOf "TypeConstructorTypeVarMissing") "y:=relation{a relation{b x}}" From 38eced0ce51d93dddfcabc33ffddbdb15b2caac8 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 14 Mar 2024 10:15:49 -0400 Subject: [PATCH 070/170] fix scotty deps in docker creation --- release.nix | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/release.nix b/release.nix index 22fb1e8a..34ed6196 100644 --- a/release.nix +++ b/release.nix @@ -51,6 +51,24 @@ let ver = "0.1.10"; sha256 = "sha256-cnTevB2qoEBMmGbqypQwJzPVF6z3cOXADbWF8OKQGAo="; } {}; + + scotty = self.callHackageDirect { + pkg = "scotty"; + ver = "0.22"; + sha256 = "sha256-DY4lKmAmqGTrzKq93Mft9bu9Qc0QcsEVpKzgoWcBL2I="; + } {}; + + wai = self.callHackageDirect { + pkg = "wai"; + ver = "3.2.4"; + sha256 = "sha256-NARmVhT5G1eMdtMM1xp7RFpevunThAB4tltCMih+qu8="; + } {}; + + wai-extra = self.callHackageDirect { + pkg = "wai-extra"; + ver = "3.1.14"; + sha256 = "sha256-wMI9eTituRbMvYvbcA9pgIwFxkbdL1+2Xw78lghfWaU="; + } {}; project-m36 = ((self.callCabal2nixWithOptions "project-m36" ./. "-f-haskell-scripting" {})); }; From 7ddcdb01c1d4fb13392fefc56c52359a5b53f983 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 14 Mar 2024 10:50:03 -0400 Subject: [PATCH 071/170] fix IN/NOT IN SQL conversion --- project-m36.cabal | 2 +- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 18 ++++++++++++++++++ src/lib/ProjectM36/SQL/Convert.hs | 8 ++++---- src/lib/ProjectM36/Server.hs | 1 - test/SQL/InterpreterTest.hs | 6 +++--- 5 files changed, 26 insertions(+), 9 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index 37a1ca08..863dd4d0 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -400,7 +400,7 @@ Test-Suite test-sql import: commontest type: exitcode-stdio-1.0 main-is: SQL/InterpreterTest.hs - Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator + Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator, ProjectM36.Interpreter TutorialD.Printer Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific, recursion-schemes diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index 7dd282ab..b520f507 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -38,6 +38,11 @@ nullAtomFunctions = HS.fromList [ funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType funcBody = FunctionBuiltInBody nullAnd }, + Function { + funcName = "sql_or", + funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType + funcBody = FunctionBuiltInBody nullOr + }, Function { funcName = "sql_coalesce_bool", -- used in where clause so that NULLs are filtered out funcType = [TypeVariableType "a", @@ -119,6 +124,19 @@ nullAnd [a,b] | isSQLBool a && isSQLBool b = do (Just a', Just b') -> nullAtom BoolAtomType (Just (BoolAtom (a' && b'))) nullAnd _other = Left AtomFunctionTypeMismatchError + +nullOr :: [Atom] -> Either AtomFunctionError Atom +nullOr [a,b] | isSQLBool a && isSQLBool b = do + let bNull = nullAtom BoolAtomType Nothing + boolTF tf = nullAtom BoolAtomType (Just (BoolAtom tf)) + pure $ case (sqlBool a, sqlBool b) of + (Nothing, Nothing) -> bNull + (Nothing, Just True) -> boolTF True + (Nothing, Just False) -> bNull + (Just True, Nothing) -> boolTF True + (Just False, Nothing) -> bNull + (Just a', Just b') -> boolTF (a' || b') +nullOr _other = Left AtomFunctionTypeMismatchError nullAtom :: AtomType -> Maybe Atom -> Atom nullAtom aType mAtom = diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 0523640b..aac30650 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -736,6 +736,7 @@ convertWhereClause :: TypeForRelExprF -> RestrictionExpr -> ConvertM Restriction convertWhereClause typeF (RestrictionExpr rexpr) = do let wrongType t = throwSQLE $ TypeMismatchError t BoolAtomType --must be boolean expression coalesceBoolF expr = FunctionAtomExpr "sql_coalesce_bool" [expr] () + sqlEq l = FunctionAtomExpr "sql_equals" l () case rexpr of IntegerLiteral{} -> wrongType IntegerAtomType DoubleLiteral{} -> wrongType DoubleAtomType @@ -769,12 +770,11 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do case reverse matches' of (match:matches) -> do firstItem <- convertScalarExpr typeF match - let inFunc a b = AtomExprPredicate (FunctionAtomExpr "sql_equals" [a,b] ()) - predExpr' = inFunc eqExpr firstItem + let predExpr' = sqlEq [eqExpr, firstItem] folder predExpr'' sexprItem = do item <- convertScalarExpr typeF sexprItem - pure $ OrPredicate (inFunc eqExpr item) predExpr'' - res <- foldM folder predExpr' matches --be careful here once we introduce NULLs + pure $ FunctionAtomExpr "sql_or" [sqlEq [eqExpr,item], predExpr''] () + res <- AtomExprPredicate . coalesceBoolF <$> foldM folder predExpr' matches case inOrNotIn of In -> pure res NotIn -> pure (NotPredicate res) diff --git a/src/lib/ProjectM36/Server.hs b/src/lib/ProjectM36/Server.hs index 701973ec..c8257e99 100644 --- a/src/lib/ProjectM36/Server.hs +++ b/src/lib/ProjectM36/Server.hs @@ -6,7 +6,6 @@ import ProjectM36.Server.EntryPoints import ProjectM36.Server.RemoteCallTypes import ProjectM36.Server.Config (ServerConfig(..)) import ProjectM36.FSType -import ProjectM36.DatabaseContext import Control.Concurrent.MVar (MVar) import System.IO (stderr, hPutStrLn) diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 7888cc72..de4acb96 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -137,12 +137,12 @@ testSelect = TestCase $ do -- any, all, some -- IN() ("SELECT * FROM s WHERE s# IN ('S1','S2')", - "(s where eq(@s#,\"S1\") or eq(@s#,\"S2\"))", - "(s where eq(@s#,\"S1\") or eq(@s#,\"S2\"))" + "(s where sql_coalesce_bool(sql_or(sql_equals(@s#,\"S1\"),sql_equals(@s#,\"S2\"))))", + "(s where s#=\"S1\" or s#=\"S2\")" ), -- NOT IN() ("SELECT * FROM s WHERE s# NOT IN ('S1','S2')", - "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))", + "(s where not sql_coalesce_bool(sql_or(sql_equals(@s#,\"S1\"),sql_equals(@s#,\"S2\"))))", "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))" ), -- where not exists From eb49bdc3915aea98c25db6d67a5d2efce4b74a94 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 14 Mar 2024 14:36:22 -0400 Subject: [PATCH 072/170] fix some more test warnings --- project-m36.cabal | 6 +++--- test/TutorialD/Interpreter/TestBase.hs | 2 -- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index 863dd4d0..f6fb658d 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -409,19 +409,19 @@ Test-Suite test-tutoriald import: commontest type: exitcode-stdio-1.0 main-is: TutorialD/InterpreterTest.hs - Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer + Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific Test-Suite test-tutoriald-atomfunctionscript import: commontest type: exitcode-stdio-1.0 - Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer + Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter main-is: TutorialD/Interpreter/AtomFunctionScript.hs Test-Suite test-tutoriald-databasecontextfunctionscript import: commontest type: exitcode-stdio-1.0 - Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer + Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter main-is: TutorialD/Interpreter/DatabaseContextFunctionScript.hs Test-Suite test-relation diff --git a/test/TutorialD/Interpreter/TestBase.hs b/test/TutorialD/Interpreter/TestBase.hs index ec6adeaf..eebdcc76 100644 --- a/test/TutorialD/Interpreter/TestBase.hs +++ b/test/TutorialD/Interpreter/TestBase.hs @@ -1,11 +1,9 @@ module TutorialD.Interpreter.TestBase where import ProjectM36.Client import ProjectM36.Interpreter -import ProjectM36.DatabaseContext import TutorialD.Interpreter import TutorialD.Interpreter.Base import ProjectM36.DateExamples -import ProjectM36.DatabaseContext import Test.HUnit import Data.Text From d6b94ee280c733f4e4a9484c5e6f0b397bc3ee0e Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 26 Mar 2024 10:08:46 -0400 Subject: [PATCH 073/170] wip add SQL function support add relation-valued attribute relexpr --- src/bin/SQL/Interpreter/Select.hs | 22 +++++- src/lib/ProjectM36/Base.hs | 4 +- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 90 +++++++++++++++++++--- src/lib/ProjectM36/Error.hs | 1 + src/lib/ProjectM36/RelationalExpression.hs | 14 ++++ src/lib/ProjectM36/SQL/Convert.hs | 55 +++++++++++-- src/lib/ProjectM36/SQL/Select.hs | 4 +- test/SQL/InterpreterTest.hs | 17 +++- test/TutorialD/Interpreter/TestBase.hs | 1 + test/TutorialD/InterpreterTest.hs | 2 +- 10 files changed, 185 insertions(+), 25 deletions(-) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 1736a0f8..62316aad 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -281,10 +281,15 @@ scalarTermP = choice [ --,cast -- subquery, -- pseudoArgFunc, -- includes NOW, NOW(), CURRENT_USER, TRIM(...), etc. + scalarFunctionP, Identifier <$> qualifiedNameP ] "scalar expression" +scalarFunctionP :: QualifiedNameP a => Parser (ScalarExprBase a) +scalarFunctionP = + try $ + FunctionApplication <$> functionNameP <*> parens (sepByComma scalarExprP) existsP :: Parser (ScalarExprBase a) existsP = do @@ -297,11 +302,22 @@ class QualifiedNameP a where -- | col, table.col, table.*, * instance QualifiedNameP ColumnProjectionName where - qualifiedNameP = - ColumnProjectionName <$> sepBy1 ((ProjectionName <$> nameP) <|> (char '*' $> Asterisk)) (char '.') <* spaceConsumer + qualifiedNameP = columnProjectionNameP instance QualifiedNameP ColumnName where - qualifiedNameP = ColumnName <$> sepBy1 nameP (char '.') <* spaceConsumer + qualifiedNameP = columnNameP + +columnNameP :: Parser ColumnName +columnNameP = + ColumnName <$> sepBy1 nameP (char '.') <* spaceConsumer + +columnProjectionNameP :: Parser ColumnProjectionName +columnProjectionNameP = + ColumnProjectionName <$> sepBy1 ((ProjectionName <$> nameP) <|> (char '*' $> Asterisk)) (char '.') <* spaceConsumer + +functionNameP :: Parser FuncName +functionNameP = do + FuncName <$> sepBy1 nameP (char '.') <* spaceConsumer withExprAliasP :: Parser WithExprAlias withExprAliasP = WithExprAlias <$> nameP diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 4672225e..082f19f3 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -234,6 +234,8 @@ data RelationalExprBase a = --- | Reference a relation variable by its name. RelationVariable RelVarName a | --- | Create a projection over attribute names. (Note that the 'AttributeNames' structure allows for the names to be inverted.) + RelationValuedAttribute AttributeName | + -- | Extract a relation from an `Atom` that is a nested relation (a relation within a relation). Project (AttributeNamesBase a) (RelationalExprBase a) | --- | Create a union of two relational expressions. The expressions should have identical attributes. Union (RelationalExprBase a) (RelationalExprBase a) | @@ -505,7 +507,7 @@ instance Hashable AtomExpr type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker -- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple. -data AtomExprBase a = AttributeAtomExpr AttributeName | +data AtomExprBase a = AttributeAtomExpr !AttributeName | NakedAtomExpr !Atom | FunctionAtomExpr FunctionName [AtomExprBase a] a | RelationAtomExpr (RelationalExprBase a) | diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index b520f507..311eaa22 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -4,6 +4,10 @@ import ProjectM36.AtomFunctionError import qualified Data.Map as M import qualified Data.HashSet as HS import ProjectM36.DataTypes.Primitive +import qualified Data.Vector as V +import ProjectM36.AtomFunction +import ProjectM36.Tuple +import ProjectM36.Relation -- analogous but not equivalent to a Maybe type due to how NULLs interact with every other value @@ -55,10 +59,26 @@ nullAtomFunctions = HS.fromList [ TypeVariableType "b", nullAtomType IntegerAtomType], funcBody = FunctionBuiltInBody (sqlIntegerBinaryFunction IntegerAtomType (\a b -> IntegerAtom (a + b))) + }, + Function { + funcName = "sql_abs", + funcType = [TypeVariableType "a", + nullAtomType IntegerAtomType], + funcBody = FunctionBuiltInBody sqlAbs + }, + Function { + funcName = "sql_negate", + funcType = [TypeVariableType "a", + nullAtomType IntegerAtomType], + funcBody = FunctionBuiltInBody (sqlIntegerUnaryFunction IntegerAtomType (\a -> IntegerAtom (- a))) + }, + Function { + funcName = "sql_max", + funcType = foldAtomFuncType (nullAtomType IntegerAtomType) (nullAtomType IntegerAtomType), + funcBody = FunctionBuiltInBody sqlMax } ] <> sqlBooleanIntegerFunctions where - sqlNull typ = ConstructedAtom "SQLNull" typ [] sqlNullable val typ = ConstructedAtom "SQLJust" (nullAtomType typ) [val] nullEq :: AtomFunctionBodyType @@ -153,12 +173,64 @@ isNull _ = False sqlIntegerBinaryFunction :: AtomType -> (Integer -> Integer -> Atom) -> [Atom] -> Either AtomFunctionError Atom sqlIntegerBinaryFunction expectedAtomType op [a,b] - | isNullOrType IntegerAtomType a && isNullOrType IntegerAtomType b = - case (a,b) of - (IntegerAtom valA, IntegerAtom valB) -> do - let res = op valA valB - pure (nullAtom expectedAtomType (Just res)) - (a',b') | isNull a' || isNull b' -> pure (nullAtom expectedAtomType Nothing) - _other -> Left AtomFunctionTypeMismatchError + | isNullOrType IntegerAtomType a && isNullOrType IntegerAtomType b = do + let extractVal (ConstructedAtom "SQLJust" _ [IntegerAtom val]) = pure val + extractVal (IntegerAtom val) = pure val + extractVal (ConstructedAtom "SQLNull" _ []) = Nothing + extractVal _ = Nothing + mValA = extractVal a + mValB = extractVal b + inull = nullAtom expectedAtomType Nothing + case (mValA, mValB) of + (Nothing, Nothing) -> pure inull + (Nothing, _) -> pure inull + (_, Nothing) -> pure inull + (Just valA, Just valB) -> pure (nullAtom expectedAtomType (Just (op valA valB))) sqlIntegerBinaryFunction _ _ _ = Left AtomFunctionTypeMismatchError - + +sqlIntegerUnaryFunction :: AtomType -> (Integer -> Atom) -> [Atom] -> Either AtomFunctionError Atom +sqlIntegerUnaryFunction expectedAtomType op [x] + | isNullOrType IntegerAtomType x = + case x of + n@(ConstructedAtom "SQLNull" _ []) -> pure n + ConstructedAtom "SQLJust" _ [IntegerAtom val] -> pure (nullAtom expectedAtomType (Just (op val))) + IntegerAtom val -> pure (nullAtom expectedAtomType (Just (op val))) + _other -> Left AtomFunctionTypeMismatchError +sqlIntegerUnaryFunction _ _ _ = Left AtomFunctionTypeMismatchError + + +sqlAbs :: [Atom] -> Either AtomFunctionError Atom +sqlAbs [IntegerAtom val] = pure $ IntegerAtom (abs val) +sqlAbs [arg] | arg == nullAtom IntegerAtomType Nothing = + pure $ nullAtom IntegerAtomType Nothing +sqlAbs [ConstructedAtom "SQLJust" aType [IntegerAtom val]] + | aType == nullAtomType IntegerAtomType = + pure $ nullAtom IntegerAtomType (Just (IntegerAtom (abs val))) +sqlAbs _other = Left AtomFunctionTypeMismatchError + +sqlMax :: [Atom] -> Either AtomFunctionError Atom +sqlMax [RelationAtom relIn] = + case oneTuple relIn of + Nothing -> pure $ nullAtom IntegerAtomType Nothing -- SQL max of empty table is NULL + Just oneTup -> + pure $ relFold (\tupIn acc -> nullMax acc (newVal tupIn)) (newVal oneTup) relIn + where + newVal tupIn = tupleAtoms tupIn V.! 0 + nullMax acc nextVal = + let mNextVal = sqlNullableIntegerToMaybe nextVal + mOldVal = sqlNullableIntegerToMaybe acc + mResult = max <$> mNextVal <*> mOldVal + in + nullAtom IntegerAtomType (case mResult of + Nothing -> Nothing + Just v -> Just (IntegerAtom v)) +sqlMax _ = Left AtomFunctionTypeMismatchError + + +sqlNullableIntegerToMaybe :: Atom -> Maybe Integer +sqlNullableIntegerToMaybe (IntegerAtom i) = Just i +sqlNullableIntegerToMaybe (ConstructedAtom "SQLJust" aType [IntegerAtom i]) | aType == nullAtomType IntegerAtomType = Just i +sqlNullableIntegerToMaybe (ConstructedAtom "SQLNull" aType []) | aType == nullAtomType IntegerAtomType = Nothing +sqlNullableIntegerToMaybe _ = Nothing + + diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs index de0a021c..85da11a4 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -167,6 +167,7 @@ data ImportError' = InvalidSHA256Error T.Text data SQLError = NotSupportedError T.Text | TypeMismatchError AtomType AtomType | NoSuchSQLFunctionError FuncName | + NoSuchSQLOperatorError OperatorName | DuplicateTableReferenceError TableAlias | MissingTableReferenceError TableAlias | TableAliasMismatchError TableAlias | diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index c3b993f2..82bff001 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -1101,6 +1101,16 @@ evalGraphRefRelationalExpr (RelationVariable name tid) = do case M.lookup name (relationVariables ctx) of Nothing -> throwError (RelVarNotDefinedError name) Just rv -> evalGraphRefRelationalExpr rv +evalGraphRefRelationalExpr (RelationValuedAttribute attrName) = do + env <- askEnv + case gre_extra env of + Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName)) + Just (Left ctxtup) -> do + atom <- lift $ except $ atomForAttributeName attrName ctxtup + case atom of + RelationAtom rel -> pure rel + other -> throwError (AtomTypeMismatchError (RelationAtomType mempty) (atomTypeForAtom other)) + Just (Right _) -> throwError (NoSuchAttributeNamesError (S.singleton attrName)) evalGraphRefRelationalExpr (Project attrNames expr) = do attrNameSet <- evalGraphRefAttributeNames attrNames expr rel <- evalGraphRefRelationalExpr expr @@ -1186,6 +1196,10 @@ typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do Nothing -> throwError (RelVarNotDefinedError rvName) Just rvExpr -> typeForGraphRefRelationalExpr rvExpr +typeForGraphRefRelationalExrp (RelationValuedAttribute attrName) = do + env <- askEnv + case gre_extra env of + typeForGraphRefRelationalExpr (Project attrNames expr) = do exprType' <- typeForGraphRefRelationalExpr expr projectionAttrs <- evalGraphRefAttributeNames attrNames expr diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index aac30650..7bca479a 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -756,7 +756,7 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do BinaryOperator exprA op exprB -> do a <- convertScalarExpr typeF exprA b <- convertScalarExpr typeF exprB - f <- lookupOperator op + f <- lookupOperator False op pure (AtomExprPredicate (coalesceBoolF (f [a,b]))) PostfixOperator expr (OperatorName ops) -> do expr' <- convertScalarExpr typeF expr @@ -803,8 +803,12 @@ convertScalarExpr typeF expr = do BinaryOperator exprA op exprB -> do a <- convertScalarExpr typeF exprA b <- convertScalarExpr typeF exprB - f <- lookupOperator op + f <- lookupOperator False op pure $ f [a,b] + FunctionApplication funcName' fargs -> do + func <- lookupFunc funcName' + fargs' <- mapM (convertScalarExpr typeF) fargs + pure (func fargs') other -> throwSQLE $ NotSupportedError ("scalar expr: " <> T.pack (show other)) convertProjectionScalarExpr :: TypeForRelExprF -> ProjectionScalarExpr -> ConvertM AtomExpr @@ -822,8 +826,16 @@ convertProjectionScalarExpr typeF expr = do BinaryOperator exprA op exprB -> do a <- convertProjectionScalarExpr typeF exprA b <- convertProjectionScalarExpr typeF exprB - f <- lookupOperator op + f <- lookupOperator False op pure $ f [a,b] + FunctionApplication fname fargs -> do + func <- lookupFunc fname + fargs' <- mapM (convertProjectionScalarExpr typeF) fargs + pure (func fargs') + PrefixOperator op sexpr -> do + func <- lookupOperator True op + arg <- convertProjectionScalarExpr typeF sexpr + pure (func [arg]) other -> throwSQLE $ NotSupportedError ("projection scalar expr: " <> T.pack (show other)) convertOrderByClause :: TypeForRelExprF -> [SortExpr] -> ConvertM [AttributeOrderExpr] @@ -1004,8 +1016,16 @@ joinTableRef typeF rvA (_c,tref) = do pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA)))) other -> throwSQLE $ NotSupportedError ("join: " <> T.pack (show other)) -lookupOperator :: OperatorName -> ConvertM ([AtomExpr] -> AtomExpr) -lookupOperator (OperatorName nam) = lookupFunc (FuncName nam) +lookupOperator :: Bool -> OperatorName -> ConvertM ([AtomExpr] -> AtomExpr) +lookupOperator isPrefix op@(OperatorName nam) + | isPrefix = do + let f n args = FunctionAtomExpr n args () + case nam of + ["-"] -> pure $ f "sql_negate" + _ -> throwSQLE $ NoSuchSQLOperatorError op + | otherwise = + lookupFunc (FuncName nam) + -- this could be amended to support more complex expressions such as coalesce by returning an [AtomExpr] -> AtomExpr function lookupFunc :: FuncName -> ConvertM ([AtomExpr] -> AtomExpr) @@ -1027,7 +1047,9 @@ lookupFunc qname = ("<>",f "sql_not_equals"), -- function missing ("+", f "sql_add"), ("and", f "sql_and"), - ("or", f "sql_or") + ("or", f "sql_or"), + ("abs", f "sql_abs"), + ("max", f "sql_max") ] -- | Used in join condition detection necessary for renames to enable natural joins. @@ -1079,7 +1101,7 @@ needsToRenameAllAttributes (RestrictionExpr sexpr) = PrefixOperator _ e1 -> rec' e1 PostfixOperator e1 _ -> rec' e1 BetweenOperator e1 _ e2 -> rec' e1 || rec' e2 - FunctionApplication _ e1 -> rec' e1 + FunctionApplication _ e1 -> or (rec' <$> e1) CaseExpr cases else' -> or (map (\(whens, then') -> or (map rec' whens) || rec' then' || maybe False rec' else') cases) QuantifiedComparison{} -> True @@ -1242,3 +1264,22 @@ convertColumnType colType constraints = aType else nullAtomType aType + +{- +select city,max(status) from s group by city; +(((s{city,status}) group ({status} as sub)) : {status2:=max(@sub)}){city,status2} rename {status2 as status} + +before: Project (AttributeNames (fromList ["attr_2","city"])) (Extend (AttributeExtendTupleExpr "attr_2" (FunctionAtomExpr "sql_max" [AttributeAtomExpr "status"] ())) (RelationVariable "s" ())) + +after: Rename (fromList [("status2","status")]) (Project (AttributeNames (fromList ["city","status2"])) (Extend (AttributeExtendTupleExpr "status2" (FunctionAtomExpr "max" [AttributeAtomExpr "sub"] ())) (Group (AttributeNames (fromList ["status"])) "sub" (Project (AttributeNames (fromList ["city","status"])) (RelationVariable "s" ()))))) +-} +{- +convertGroupBy :: TypeForRelExprF -> [GroupByExpr] -> [SelectItem] -> RelationalExpr -> ConvertM RelationalExpr +convertGroupBy typeF groupBys sqlProjection (Project renames extending) = do + --first, check that projection includes an aggregate, otherwise, there's no point + --find aggregate functions at the top-level (including within other functions such as 1+max(x)), and refocus them on the group attribute projected on the aggregate target + -- do we need an operator to apply a relexpr to a subrelation? For example, it would be useful to apply a projection across all the subrelations, and types are maintained + let modAggregate +-} +aggregateFunctions :: S.Set FuncName +aggregateFunctions = S.fromList $ map (FuncName . (:[])) ["max", "min", "sum"] diff --git a/src/lib/ProjectM36/SQL/Select.hs b/src/lib/ProjectM36/SQL/Select.hs index b3e06ab0..b90863a5 100644 --- a/src/lib/ProjectM36/SQL/Select.hs +++ b/src/lib/ProjectM36/SQL/Select.hs @@ -89,7 +89,7 @@ data ScalarExprBase n = | PrefixOperator OperatorName (ScalarExprBase n) | PostfixOperator (ScalarExprBase n) OperatorName | BetweenOperator (ScalarExprBase n) (ScalarExprBase n) (ScalarExprBase n) - | FunctionApplication FuncName (ScalarExprBase n) + | FunctionApplication FuncName [ScalarExprBase n] | CaseExpr { caseWhens :: [([ScalarExprBase n],ScalarExprBase n)], caseElse :: Maybe (ScalarExprBase n) } | QuantifiedComparison { qcExpr :: ScalarExprBase n, @@ -181,7 +181,7 @@ newtype TableAlias = TableAlias { unTableAlias :: Text } deriving newtype (Monoid, Semigroup, NFData) newtype FuncName = FuncName [Text] - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, Ord) deriving Serialise via WineryVariant FuncName deriving newtype NFData diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index de4acb96..7cb5e37b 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -50,7 +50,7 @@ testSelect = TestCase $ do (tgraph,transId) <- freshTransactionGraph sqlDBContext (sess, conn) <- dateExamplesConnection emptyNotificationCallback - let readTests = [ + let readTests = [{- -- simple relvar ("SELECT * FROM s", "(s)", "(s)"), -- simple projection @@ -145,8 +145,21 @@ testSelect = TestCase $ do "(s where not sql_coalesce_bool(sql_or(sql_equals(@s#,\"S1\"),sql_equals(@s#,\"S2\"))))", "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))" ), + -- function application + ("SELECT abs(-4)", + "((relation{}{tuple{}}:{attr_1:=sql_abs(sql_negate(4))}){attr_1})", + "(relation{tuple{attr_1 SQLJust 4}})" + ),-} -- where not exists -- group by + ("SELECT city,max(status) FROM s GROUP BY city", + "((((s{city,status}) group ({status} as sub)) : {status2:=sql_max(@sub)}){city,status2} rename {status2 as status})", + "(relation{city Text, status Integer}{tuple{city \"London\", status 20}, tuple{city \"Paris\", status 30}, tuple{city \"Athens\", status 30}})" + ){-, + -- group by with aggregate column alias + ("SELECT city,max(status) as max FROM s GROUP BY city", +... +), -- group by having -- limit -- case when @@ -210,7 +223,7 @@ testSelect = TestCase $ do "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust False}})"), ("SELECT NULL AND TRUE", "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNull,True)}){attr_1})", - "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})") + "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})")-} ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just sqlDBContext, diff --git a/test/TutorialD/Interpreter/TestBase.hs b/test/TutorialD/Interpreter/TestBase.hs index eebdcc76..5a70a4e2 100644 --- a/test/TutorialD/Interpreter/TestBase.hs +++ b/test/TutorialD/Interpreter/TestBase.hs @@ -4,6 +4,7 @@ import ProjectM36.Interpreter import TutorialD.Interpreter import TutorialD.Interpreter.Base import ProjectM36.DateExamples +import ProjectM36.DatabaseContext import Test.HUnit import Data.Text diff --git a/test/TutorialD/InterpreterTest.hs b/test/TutorialD/InterpreterTest.hs index cfd172f2..9ae8c461 100644 --- a/test/TutorialD/InterpreterTest.hs +++ b/test/TutorialD/InterpreterTest.hs @@ -804,7 +804,7 @@ testDDLHash = TestCase $ do Right hash2 <- getDDLHash sessionId dbconn assertBool "add relvar" (hash1 /= hash2) -- the test should break if the hash is calculated differently - assertEqual "static hash check" "Gu8Uaw7WAl484jAEprlbeXRnF1tKKX4MvYBjL1TPnHI=" (B64.encode (_unSecureHash hash1)) + assertEqual "static hash check" "2agn0YDfvffgBe23XHZEqLni+JOWi3ex0P3vxRcYKk0=" (B64.encode (_unSecureHash hash1)) -- remove an rv executeTutorialD sessionId dbconn "undefine x" Right hash3 <- getDDLHash sessionId dbconn From 5a32cf840f3eeb80a8e9095c6b487dfebbdde879 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 2 Apr 2024 00:23:53 -0400 Subject: [PATCH 074/170] support relational expression application on relation-valued attributes resolves #354 --- .../TutorialD/Interpreter/RelationalExpr.hs | 16 +++++++--- src/bin/TutorialD/Printer.hs | 1 + src/lib/ProjectM36/HashSecurely.hs | 5 ++-- src/lib/ProjectM36/NormalizeExpr.hs | 1 + src/lib/ProjectM36/Relation/Representation.hs | 4 +++ src/lib/ProjectM36/RelationalExpression.hs | 30 +++++++++++++++++-- src/lib/ProjectM36/SQL/Convert.hs | 1 + src/lib/ProjectM36/StaticOptimizer.hs | 4 +++ .../TransGraphRelationalExpression.hs | 1 + src/lib/ProjectM36/WithNameExpr.hs | 1 + 10 files changed, 55 insertions(+), 9 deletions(-) create mode 100644 src/lib/ProjectM36/Relation/Representation.hs diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs index 31539531..09662043 100644 --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -158,6 +158,11 @@ relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relTerm = parens relExprP <|> makeRelationP <|> (relVarP <* notFollowedBy "(") + <|> relationValuedAttributeP + +relationValuedAttributeP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) +relationValuedAttributeP = do + RelationValuedAttribute <$> (single '@' *> attributeNameP) restrictionPredicateP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) restrictionPredicateP = makeExprParser predicateTerm predicateOperators @@ -205,10 +210,9 @@ consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a) consumeAtomExprP consume = try functionAtomExprP <|> try (parens (constructedAtomExprP True)) <|> constructedAtomExprP consume <|> + relationalAtomExprP <|> attributeAtomExprP <|> - try nakedAtomExprP <|> - relationalAtomExprP - + try nakedAtomExprP attributeAtomExprP :: Parser (AtomExprBase a) attributeAtomExprP = do @@ -236,7 +240,11 @@ functionAtomExprP = FunctionAtomExpr <$> functionNameP <*> parens (sepBy atomExprP comma) <*> parseMarkerP relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) -relationalAtomExprP = RelationAtomExpr <$> relExprP +relationalAtomExprP = do + expr <- relExprP + case expr of + RelationValuedAttribute attrName -> pure $ AttributeAtomExpr attrName + other -> pure $ RelationAtomExpr other stringAtomP :: Parser Atom stringAtomP = TextAtom <$> quotedString diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index 2df9c456..b8bc64a1 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -82,6 +82,7 @@ instance Pretty Attribute where instance Pretty RelationalExpr where pretty (RelationVariable n _) = pretty n pretty (ExistingRelation r) = pretty r + pretty (RelationValuedAttribute attrName) = "@" <> pretty attrName pretty (NotEquals a b) = pretty' a <+> "!=" <+> pretty' b pretty (Equals a b) = pretty' a <+> "==" <+> pretty' b pretty (Project ns r) = pretty' (ignoreProjects r) <> pretty ns diff --git a/src/lib/ProjectM36/HashSecurely.hs b/src/lib/ProjectM36/HashSecurely.hs index 2ca45b9e..dfc3784e 100644 --- a/src/lib/ProjectM36/HashSecurely.hs +++ b/src/lib/ProjectM36/HashSecurely.hs @@ -72,9 +72,10 @@ hashBytesL ctx name = foldr (\(SHash i) ctx'@(SHA256.Ctx !bs) -> bs `seq` hashBy instance HashBytes a => HashBytes (RelationalExprBase a) where hashBytes (MakeRelationFromExprs mAttrs tupleExprs) ctx = hashBytesL ctx "MakeRelationFromExprs" [SHash mAttrs, SHash tupleExprs] - hashBytes (MakeStaticRelation attrs tupSet) ctx = -- blowing up here! + hashBytes (MakeStaticRelation attrs tupSet) ctx = hashBytesL ctx "MakeStaticRelation" [SHash attrs, SHash tupSet] --- hashBytes _ ctx = ctx + hashBytes (RelationValuedAttribute attrName) ctx = + hashBytesL ctx "RelationValuedAttribute" [SHash attrName] hashBytes (ExistingRelation (Relation attrs tupSet)) ctx = hashBytesL ctx "ExistingRelation" [SHash tupSet, SHash attrs] hashBytes (RelationVariable rvName marker) ctx = diff --git a/src/lib/ProjectM36/NormalizeExpr.hs b/src/lib/ProjectM36/NormalizeExpr.hs index 8b646a4c..e6b724f5 100644 --- a/src/lib/ProjectM36/NormalizeExpr.hs +++ b/src/lib/ProjectM36/NormalizeExpr.hs @@ -25,6 +25,7 @@ processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet) processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel) --requires current trans id and graph +processRelationalExpr (RelationValuedAttribute attrName) = pure (RelationValuedAttribute attrName) processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> askMarker processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB diff --git a/src/lib/ProjectM36/Relation/Representation.hs b/src/lib/ProjectM36/Relation/Representation.hs new file mode 100644 index 00000000..0f6e59ec --- /dev/null +++ b/src/lib/ProjectM36/Relation/Representation.hs @@ -0,0 +1,4 @@ +module ProjectM36.Relation.Representation where +import ProjectM36.Base + + diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index 82bff001..38a03139 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -1196,10 +1196,23 @@ typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do Nothing -> throwError (RelVarNotDefinedError rvName) Just rvExpr -> typeForGraphRefRelationalExpr rvExpr -typeForGraphRefRelationalExrp (RelationValuedAttribute attrName) = do +typeForGraphRefRelationalExpr (RelationValuedAttribute attrName) = do env <- askEnv case gre_extra env of - + Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName)) -- or can this be an attribute at the top-level? + Just (Left ctxtup) -> do + atom <- lift $ except $ atomForAttributeName attrName ctxtup + case atom of + RelationAtom rel -> pure (emptyRelationWithAttrs (attributes rel)) + other -> throwError (AtomTypeMismatchError (RelationAtomType mempty) (atomTypeForAtom other)) + Just (Right attrs) -> do + case A.atomTypeForAttributeName attrName attrs of + Left{} -> throwError (NoSuchAttributeNamesError (S.singleton attrName)) + Right typ -> do + case typ of + RelationAtomType relAttrs -> pure $ emptyRelationWithAttrs relAttrs + other -> throwError (AtomTypeMismatchError (RelationAtomType A.emptyAttributes) other) + typeForGraphRefRelationalExpr (Project attrNames expr) = do exprType' <- typeForGraphRefRelationalExpr expr projectionAttrs <- evalGraphRefAttributeNames attrNames expr @@ -1295,6 +1308,7 @@ mkEmptyRelVars = M.map mkEmptyRelVar mkEmptyRelVar expr@MakeRelationFromExprs{} = expr --do not truncate here because we might lose essential type information in emptying the tuples mkEmptyRelVar (MakeStaticRelation attrs _) = MakeStaticRelation attrs emptyTupleSet mkEmptyRelVar (ExistingRelation rel) = ExistingRelation (emptyRelationWithAttrs (attributes rel)) + mkEmptyRelVar x@RelationValuedAttribute{} = x mkEmptyRelVar rv@RelationVariable{} = Restrict (NotPredicate TruePredicate) rv mkEmptyRelVar (Project attrNames expr) = Project attrNames (mkEmptyRelVar expr) mkEmptyRelVar (Union exprA exprB) = Union (mkEmptyRelVar exprA) (mkEmptyRelVar exprB) @@ -1370,6 +1384,7 @@ instance ResolveGraphRefTransactionMarker GraphRefRelationalExpr where MakeRelationFromExprs mAttrs <$> resolve tupleExprs resolve orig@MakeStaticRelation{} = pure orig resolve orig@ExistingRelation{} = pure orig + resolve orig@RelationValuedAttribute{} = pure orig resolve orig@(RelationVariable rvName UncommittedContextMarker) = do rvMap <- relationVariables <$> getStateContext case M.lookup rvName rvMap of @@ -1468,4 +1483,13 @@ applyRestrictionCollapse orig@(Restrict npred@(NotPredicate _) expr) = _ -> orig applyRestrictionCollapse expr = expr - +firstAtomForAttributeName :: AttributeName -> [RelationTuple] -> GraphRefRelationalExprM Atom +firstAtomForAttributeName attrName tuples = do + let folder tup acc = + case atomForAttributeName attrName tup of + Left{} -> acc + Right atom -> Just atom + case foldr folder Nothing tuples of + Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName)) + Just match -> pure match + diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 7bca479a..ced16c76 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -1125,6 +1125,7 @@ pushDownAttributeRename renameSet matchExpr targetExpr = x@MakeRelationFromExprs{} -> x x@MakeStaticRelation{} -> x x@ExistingRelation{} -> x + x@RelationValuedAttribute{} -> x x@RelationVariable{} -> x Project attrs expr -> Project attrs (push expr) Union exprA exprB -> Union (push exprA) (push exprB) diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index 60d75fec..4e02415a 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -183,6 +183,8 @@ optimizeGraphRefRelationalExpr e@MakeRelationFromExprs{} = pure e optimizeGraphRefRelationalExpr e@(ExistingRelation _) = pure e +optimizeGraphRefRelationalExpr e@(RelationValuedAttribute{}) = pure e + optimizeGraphRefRelationalExpr e@(RelationVariable _ _) = pure e --remove project of attributes which removes no attributes @@ -500,6 +502,7 @@ applyStaticRestrictionCollapse expr = MakeRelationFromExprs _ _ -> expr MakeStaticRelation _ _ -> expr ExistingRelation _ -> expr + RelationValuedAttribute{} -> expr RelationVariable _ _ -> expr With _ _ -> expr Project attrs subexpr -> @@ -546,6 +549,7 @@ applyStaticRestrictionPushdown expr = case expr of MakeRelationFromExprs _ _ -> expr MakeStaticRelation _ _ -> expr ExistingRelation _ -> expr + RelationValuedAttribute{} -> expr RelationVariable _ _ -> expr With _ _ -> expr Project _ _ -> expr diff --git a/src/lib/ProjectM36/TransGraphRelationalExpression.hs b/src/lib/ProjectM36/TransGraphRelationalExpression.hs index e9ad5794..1ba247b0 100644 --- a/src/lib/ProjectM36/TransGraphRelationalExpression.hs +++ b/src/lib/ProjectM36/TransGraphRelationalExpression.hs @@ -64,6 +64,7 @@ processTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = pure (MakeRelationFromExprs (Just attrExprs') tupleExprs') processTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet) processTransGraphRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel) +processTransGraphRelationalExpr (RelationValuedAttribute attrName) = pure (RelationValuedAttribute attrName) processTransGraphRelationalExpr (RelationVariable rvname transLookup) = RelationVariable rvname <$> findTransId transLookup processTransGraphRelationalExpr (Project transAttrNames expr) = diff --git a/src/lib/ProjectM36/WithNameExpr.hs b/src/lib/ProjectM36/WithNameExpr.hs index b8127d05..0a39f790 100644 --- a/src/lib/ProjectM36/WithNameExpr.hs +++ b/src/lib/ProjectM36/WithNameExpr.hs @@ -18,6 +18,7 @@ substituteWithNameMacros :: substituteWithNameMacros _ e@MakeRelationFromExprs{} = e substituteWithNameMacros _ e@MakeStaticRelation{} = e substituteWithNameMacros _ e@ExistingRelation{} = e +substituteWithNameMacros _ e@RelationValuedAttribute{} = e substituteWithNameMacros macros e@(RelationVariable rvname tid) = let macroFilt (WithNameExpr macroName macroTid, _) = rvname == macroName && tid== macroTid in From dd0114e535c5f1ea6cb516696b64aeb919266017 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 14 Apr 2024 16:52:08 -0400 Subject: [PATCH 075/170] WIP: SQL group by --- src/lib/ProjectM36/SQL/Convert.hs | 75 ++++++++++++++++++++++++++----- src/lib/ProjectM36/SQL/Select.hs | 2 +- 2 files changed, 65 insertions(+), 12 deletions(-) diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index ced16c76..6d98973c 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -561,9 +561,11 @@ convertSelect typeF sel = do Just tExpr -> convertTableExpr typeF' tExpr -- traceShowM ("table aliases", tAliasMap) let explicitWithF = if null wExprs then id else With wExprs - + groupByExprs = case tableExpr sel of + Nothing -> [] + Just texpr -> groupByClause texpr -- convert projection using table alias map to resolve column names - projF <- convertProjection typeF' (projectionClause sel) + projF <- convertProjection typeF' (projectionClause sel) groupByExprs -- add with clauses withAssocs <- tableAliasesAsWithNameAssocs let withF = case withAssocs of @@ -601,7 +603,7 @@ convertSubSelect typeF sel = do -- traceShowM ("convertSubSelect"::String, colMap) let explicitWithF = if null wExprs then id else With wExprs -- convert projection using table alias map to resolve column names - projF <- convertProjection typeF' (projectionClause sel) -- the projection can only project on attributes from the subselect table expression + projF <- convertProjection typeF' (projectionClause sel) [] -- the projection can only project on attributes from the subselect table expression -- add with clauses withAssocs <- tableAliasesAsWithNameAssocs let withF = case withAssocs of @@ -659,9 +661,9 @@ convertSelectItem typeF acc (c,selItem) = findOneColumn (ColumnName [name]) colinfo colProjName = throwSQLE $ UnexpectedColumnProjectionName colProjName -convertProjection :: TypeForRelExprF -> [SelectItem] -> ConvertM (RelationalExpr -> RelationalExpr) -convertProjection typeF selItems = do --- traceShowM ("convertProjection", selItems) +convertProjection :: TypeForRelExprF -> [SelectItem] -> [GroupByExpr] -> ConvertM (RelationalExpr -> RelationalExpr) +convertProjection typeF selItems groupBys = do +-- traceShowM ("convertProjection", selItems, groupBys) let emptyTask = SelectItemsConvertTask { taskProjections = S.empty, taskRenames = mempty, taskExtenders = mempty } @@ -1274,13 +1276,64 @@ before: Project (AttributeNames (fromList ["attr_2","city"])) (Extend (Attribute after: Rename (fromList [("status2","status")]) (Project (AttributeNames (fromList ["city","status2"])) (Extend (AttributeExtendTupleExpr "status2" (FunctionAtomExpr "max" [AttributeAtomExpr "sub"] ())) (Group (AttributeNames (fromList ["status"])) "sub" (Project (AttributeNames (fromList ["city","status"])) (RelationVariable "s" ()))))) -} -{- -convertGroupBy :: TypeForRelExprF -> [GroupByExpr] -> [SelectItem] -> RelationalExpr -> ConvertM RelationalExpr -convertGroupBy typeF groupBys sqlProjection (Project renames extending) = do + +-- (s group ({all but city} as sub): {maxstatus:=max(@sub{status})}){city,maxstatus} +-- select city,max(status) from s group by city; + +convertGroupBy :: TypeForRelExprF -> [GroupByExpr] -> [SelectItem] -> ConvertM GroupByInfo +convertGroupBy typeF groupBys sqlProjection = do --first, check that projection includes an aggregate, otherwise, there's no point --find aggregate functions at the top-level (including within other functions such as 1+max(x)), and refocus them on the group attribute projected on the aggregate target -- do we need an operator to apply a relexpr to a subrelation? For example, it would be useful to apply a projection across all the subrelations, and types are maintained - let modAggregate --} +-- foldM convertGroupByExpr emptyGroupByInfo sqlProjection + -- each scalar expr must appear at the top-level SelectItem list +-- convertGroupByExpr acc + foldM collectGroupByInfo emptyGroupByInfo sqlProjection + where + collectGroupByInfo info (sexpr, _mAlias) = do + if containsAggregate sexpr then do + -- validate that there is a corresponding group by + + pure $ info { aggregates = sexpr : aggregates info } + else + pure $ info + +data GroupByInfo = + GroupByInfo { aggregates :: [ProjectionScalarExpr] + + } + deriving (Show, Eq) + +emptyGroupByInfo :: GroupByInfo +emptyGroupByInfo = GroupByInfo { aggregates = []} + aggregateFunctions :: S.Set FuncName aggregateFunctions = S.fromList $ map (FuncName . (:[])) ["max", "min", "sum"] + + +containsAggregate :: ProjectionScalarExpr -> Bool +containsAggregate expr = + case expr of + IntegerLiteral{} -> False + DoubleLiteral{} -> False + StringLiteral{} -> False + BooleanLiteral{} -> False + NullLiteral -> False + Identifier{} -> False + BinaryOperator e1 op e2 -> containsAggregate e1 || containsAggregate e2 || opAgg op + PrefixOperator op e1 -> containsAggregate e1 || opAgg op + PostfixOperator e1 op -> containsAggregate e1 || opAgg op + BetweenOperator e1 e2 e3 -> containsAggregate e1 || containsAggregate e2 || containsAggregate e3 + FunctionApplication fname args -> funcAgg fname || or (map containsAggregate args) + c@CaseExpr{} -> or (cElse : concatMap (\(whens, res) -> containsAggregate res : map containsAggregate whens) (caseWhens c)) + where + cElse = case caseElse c of + Just e -> containsAggregate e + Nothing -> False + q@QuantifiedComparison{} -> containsAggregate (qcExpr q) + InExpr _ e1 _ -> containsAggregate e1 + BooleanOperatorExpr e1 opName e2 -> opAgg opName || containsAggregate e1 || containsAggregate e2 + ExistsExpr{} -> False + where + opAgg _opName = False + funcAgg fname = fname `S.member` aggregateFunctions diff --git a/src/lib/ProjectM36/SQL/Select.hs b/src/lib/ProjectM36/SQL/Select.hs index b90863a5..84c9cb6e 100644 --- a/src/lib/ProjectM36/SQL/Select.hs +++ b/src/lib/ProjectM36/SQL/Select.hs @@ -113,7 +113,7 @@ data InPredicateValue = InList [ScalarExpr] | InQueryExpr Select | InScalarExpr deriving (Eq, Show, Generic, NFData) deriving Serialise via WineryVariant InPredicateValue -data GroupByExpr = Group ScalarExpr +data GroupByExpr = Group ProjectionScalarExpr deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant GroupByExpr From b1b59ff7cc240e12592df017eb100cf13678d872 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 28 Apr 2024 18:50:59 -0400 Subject: [PATCH 076/170] basic group by support --- src/bin/SQL/Interpreter/Select.hs | 4 +- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 2 +- src/lib/ProjectM36/Error.hs | 3 + src/lib/ProjectM36/SQL/Convert.hs | 202 ++++++++++++++++++++--- src/lib/ProjectM36/SQL/Select.hs | 45 ++++- test/SQL/InterpreterTest.hs | 21 ++- 6 files changed, 240 insertions(+), 37 deletions(-) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 62316aad..599774e8 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -106,10 +106,10 @@ whereP = reserved "where" *> (RestrictionExpr <$> scalarExprP) groupByP :: Parser [GroupByExpr] groupByP = - reserveds "group by" *> sepBy1 (Group <$> scalarExprP) comma + reserveds "group by" *> sepBy1 (GroupByExpr <$> scalarExprP) comma havingP :: Parser HavingExpr -havingP = reserved "having" *> (Having <$> scalarExprP) +havingP = reserved "having" *> (HavingExpr <$> scalarExprP) orderByP :: Parser [SortExpr] orderByP = diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index 311eaa22..616cb484 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -74,7 +74,7 @@ nullAtomFunctions = HS.fromList [ }, Function { funcName = "sql_max", - funcType = foldAtomFuncType (nullAtomType IntegerAtomType) (nullAtomType IntegerAtomType), + funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType), funcBody = FunctionBuiltInBody sqlMax } ] <> sqlBooleanIntegerFunctions diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs index 85da11a4..a79bac2b 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -181,5 +181,8 @@ data SQLError = NotSupportedError T.Text | UnexpectedColumnProjectionName ColumnProjectionName | AmbiguousColumnResolutionError ColumnName | DuplicateColumnAliasError ColumnAlias | + AggregateGroupByMismatchError ProjectionScalarExpr | + GroupByColumnNotReferencedInGroupByError [ProjectionScalarExpr] | + UnsupportedGroupByProjectionError ProjectionScalarExpr | SQLRelationalError RelationalError deriving (Show, Eq, Generic, Typeable, NFData) diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 6d98973c..e8dfc747 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -31,6 +31,7 @@ import Control.Monad.Trans.State (StateT, get, put, runStateT, evalStateT) import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Trans.Class (lift) +--import qualified Data.HashSet as HS import Debug.Trace @@ -58,8 +59,16 @@ evalConvertM tcontext m = runIdentity (runExceptT (evalStateT m tcontext)) data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set ColumnProjectionName, taskRenames :: [(ColumnProjectionName, ColumnAlias)], - taskExtenders :: [ExtendTupleExpr] + taskExtenders :: [ExtendTupleExpr], + taskGroups :: [S.Set ColumnProjectionName] } deriving (Show, Eq) + +emptyTask :: SelectItemsConvertTask +emptyTask = SelectItemsConvertTask { taskProjections = S.empty, + taskRenames = mempty, + taskGroups = mempty, + taskExtenders = mempty } + -- (real attribute name in table- immutable, (renamed "preferred" attribute name needed to disambiguate names on conflict, set of names which are used to reference the "preferred" name) type AttributeAlias = AttributeName @@ -574,6 +583,7 @@ convertSelect typeF sel = do finalRelExpr = explicitWithF (withF (projF (convertExpr dfExpr))) -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes -- apply rename reduction- this could be applied by the static query optimizer, but we do it here to simplify the tests so that they aren't polluted with redundant renames +-- traceShowM ("final expr"::String, finalRelExpr) pure (dfExpr { convertExpr = finalRelExpr }) @@ -622,8 +632,8 @@ convertSubSelect typeF sel = do pure (applyF renamedExpr) -convertSelectItem :: TypeForRelExprF -> SelectItemsConvertTask -> (Int,SelectItem) -> ConvertM SelectItemsConvertTask -convertSelectItem typeF acc (c,selItem) = +convertSelectItem :: TypeForRelExprF -> SelectItemsConvertTask -> (Int, SelectItem) -> ConvertM SelectItemsConvertTask +convertSelectItem typeF acc (c,selItem) = case selItem of -- select * from x (Identifier (ColumnProjectionName [Asterisk]), Nothing) -> @@ -650,26 +660,38 @@ convertSelectItem typeF acc (c,selItem) = (scalarExpr, mAlias) -> do let attrName' (Just (ColumnAlias nam)) _ = nam attrName' Nothing c' = "attr_" <> T.pack (show c') - atomExpr <- convertProjectionScalarExpr typeF scalarExpr - let newAttrName = attrName' mAlias c + newAttrName = attrName' mAlias c + atomExpr <- processSQLAggregateFunctions <$> convertProjectionScalarExpr typeF scalarExpr -- we need to apply the projections after the extension! pure $ acc { taskExtenders = AttributeExtendTupleExpr newAttrName atomExpr : taskExtenders acc, - taskProjections = S.insert (ColumnProjectionName [ProjectionName newAttrName]) (taskProjections acc) + taskProjections = S.insert (ColumnProjectionName [ProjectionName newAttrName]) (taskProjections acc) } where colinfo (ColumnProjectionName [ProjectionName name]) = do findOneColumn (ColumnName [name]) colinfo colProjName = throwSQLE $ UnexpectedColumnProjectionName colProjName +{- processGroupBy e@(sexpr, alias) = (replaceProjScalarExpr groupByReplacer sexpr, alias) + groupByReplacer expr = + case expr of + FunctionApplication "sql_max" [targetColumn] -> FunctionApplication "sql_max" [ + _ -> expr-} + convertProjection :: TypeForRelExprF -> [SelectItem] -> [GroupByExpr] -> ConvertM (RelationalExpr -> RelationalExpr) convertProjection typeF selItems groupBys = do -- traceShowM ("convertProjection", selItems, groupBys) - let emptyTask = SelectItemsConvertTask { taskProjections = S.empty, - taskRenames = mempty, - taskExtenders = mempty } + groupInfo <- convertGroupBy typeF groupBys selItems +-- traceShowM ("convertProjection grouping"::String, groupInfo) -- attrName' (Just (ColumnAlias nam)) _ = nam -- attrName' Nothing c = "attr_" <> T.pack (show c) task <- foldM (convertSelectItem typeF) emptyTask (zip [1::Int ..] selItems) +-- traceShowM ("convertProjection task"::String, task) + -- SQL supports only one grouping at a time, but multiple aggregations, so we create the group as attribute "_sql_aggregate" and the aggregations as fold projections on it + fGroup <- if not (null (nonAggregates groupInfo)) then + pure $ Group (InvertedAttributeNames + (S.fromList (map fst (nonAggregates groupInfo)))) "_sql_aggregate" + else + pure id --apply projections fProjection <- if S.null (taskProjections task) then pure id @@ -686,12 +708,14 @@ convertProjection typeF selItems groupBys = do pure $ Project attrsProj -- apply extensions let fExtended = foldr (\ext acc -> (Extend ext) . acc) id (taskExtenders task) + -- process SQL aggregates by replacing projections +-- let fAggregates -- apply rename renamesSet <- foldM (\acc (qProjName, (ColumnAlias newName)) -> do oldName <- convertColumnProjectionName qProjName pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) let fRenames = if S.null renamesSet then id else Rename renamesSet - pure (fProjection . fExtended . fRenames) + pure (fProjection . fExtended . fRenames . fGroup) convertUnqualifiedColumnName :: UnqualifiedColumnName -> AttributeName convertUnqualifiedColumnName (UnqualifiedColumnName nam) = nam @@ -1054,6 +1078,9 @@ lookupFunc qname = ("max", f "sql_max") ] +sqlAggregateFunctions :: S.Set FunctionName +sqlAggregateFunctions = S.fromList ["sql_max", "sql_min", "sql_avg"] + -- | Used in join condition detection necessary for renames to enable natural joins. commonAttributeNames :: TypeForRelExprF -> RelationalExpr -> RelationalExpr -> ConvertM (S.Set AttributeName, S.Set AttributeName, S.Set AttributeName) commonAttributeNames typeF rvA rvB = @@ -1281,31 +1308,72 @@ after: Rename (fromList [("status2","status")]) (Project (AttributeNames (fromLi -- select city,max(status) from s group by city; convertGroupBy :: TypeForRelExprF -> [GroupByExpr] -> [SelectItem] -> ConvertM GroupByInfo -convertGroupBy typeF groupBys sqlProjection = do +convertGroupBy _typeF groupBys sqlProjection = do --first, check that projection includes an aggregate, otherwise, there's no point --find aggregate functions at the top-level (including within other functions such as 1+max(x)), and refocus them on the group attribute projected on the aggregate target -- do we need an operator to apply a relexpr to a subrelation? For example, it would be useful to apply a projection across all the subrelations, and types are maintained -- foldM convertGroupByExpr emptyGroupByInfo sqlProjection -- each scalar expr must appear at the top-level SelectItem list -- convertGroupByExpr acc - foldM collectGroupByInfo emptyGroupByInfo sqlProjection - where - collectGroupByInfo info (sexpr, _mAlias) = do - if containsAggregate sexpr then do + -- search group by exprs to find the matching sexpr- if more than one matches, error + --todo: handle asterisk + let findMatchingProjection expr@(GroupByExpr gbexpr) = + let exprMatcher (projExpr, _alias) acc = + if containsProjScalarExpr gbexpr projExpr then + projExpr : acc + else + acc + in + case foldr exprMatcher mempty sqlProjection of + [] -> throwSQLE (AggregateGroupByMismatchError gbexpr) + [match] -> if containsAggregate match then + pure (AggGroupByItem match expr) + else + pure (NonAggGroupByItem match expr) + _matches -> throwSQLE (AggregateGroupByMismatchError gbexpr) + collectGroupByInfo info gbsexpr = do -- validate that there is a corresponding group by - - pure $ info { aggregates = sexpr : aggregates info } - else - pure $ info + matchExpr <- findMatchingProjection gbsexpr + case matchExpr of + AggGroupByItem pe _gb -> + pure $ info { aggregates = pe : aggregates info } + NonAggGroupByItem (Identifier colName) gb -> do + aname <- convertColumnProjectionName colName + pure $ info { nonAggregates = (aname, gb) : nonAggregates info } + NonAggGroupByItem pe _ -> do + throwSQLE (UnsupportedGroupByProjectionError pe) + -- find select items which are not mentioned in the group by expression and make sure that are in the aggregates info +-- collectNonGroupByInfo :: [ProjectionScalarExpr] -> GroupByInfo -> SelectItem -> ConvertM GroupByInfo + collectNonGroupByInfo info (projExpr, _alias) = + if containsAggregate projExpr then + pure (info { aggregates = projExpr : aggregates info }) + else + pure info + + groups1 <- foldM collectGroupByInfo emptyGroupByInfo groupBys + groups2 <- foldM collectNonGroupByInfo groups1 sqlProjection +{- let sqlProj = HS.fromList (map fst sqlProjection) + groupByProj = HS.fromList (aggregates groups2 <> map fst (nonAggregates groups2)) + diff = HS.difference sqlProj groupByProj + if HS.null diff then-} + pure groups2 +{- else + throwSQLE (GroupByColumnNotReferencedInGroupByError (HS.toList diff))-} + + + +data GroupByItem = AggGroupByItem ProjectionScalarExpr GroupByExpr | + NonAggGroupByItem ProjectionScalarExpr GroupByExpr + deriving (Show, Eq) data GroupByInfo = - GroupByInfo { aggregates :: [ProjectionScalarExpr] - + GroupByInfo { aggregates :: [ProjectionScalarExpr], -- ^ mentioned in group by clause and uses aggregation + nonAggregates :: [(AttributeName, GroupByExpr)] -- ^ mentioned in group by clause by not aggregations } deriving (Show, Eq) emptyGroupByInfo :: GroupByInfo -emptyGroupByInfo = GroupByInfo { aggregates = []} +emptyGroupByInfo = GroupByInfo { aggregates = [], nonAggregates = [] } aggregateFunctions :: S.Set FuncName aggregateFunctions = S.fromList $ map (FuncName . (:[])) ["max", "min", "sum"] @@ -1337,3 +1405,93 @@ containsAggregate expr = where opAgg _opName = False funcAgg fname = fname `S.member` aggregateFunctions + +-- | Returns True iff a projection scalar expr within a larger expression. Used for group by aggregation validation. +containsProjScalarExpr :: ProjectionScalarExpr -> ProjectionScalarExpr -> Bool +containsProjScalarExpr needle haystack = + if needle == haystack then + True + else + case haystack of + IntegerLiteral{} -> False + DoubleLiteral{} -> False + StringLiteral{} -> False + BooleanLiteral{} -> False + NullLiteral -> False + Identifier{} -> False + BinaryOperator e1 _op e2 -> con e1 || con e2 + PrefixOperator _op e1 -> con e1 + PostfixOperator e1 _op -> con e1 + BetweenOperator e1 e2 e3 -> con e1 || con e2 || con e3 + FunctionApplication _fname args -> or (map con args) + c@CaseExpr{} -> or (cElse : concatMap (\(whens, res) -> con res : map con whens) (caseWhens c)) + where + cElse = case caseElse c of + Just e -> con e + Nothing -> False + q@QuantifiedComparison{} -> con (qcExpr q) + InExpr _ e1 _ -> containsAggregate e1 + BooleanOperatorExpr e1 _opName e2 -> con e1 || con e2 + ExistsExpr{} -> False + where + con h = containsProjScalarExpr needle h + +-- depth first replacement for scalar expr modification +replaceProjScalarExpr :: (ProjectionScalarExpr -> ProjectionScalarExpr) -> ProjectionScalarExpr -> ProjectionScalarExpr +replaceProjScalarExpr r orig = + case orig of + IntegerLiteral{} -> r orig + DoubleLiteral{} -> r orig + StringLiteral{} -> r orig + BooleanLiteral{} -> r orig + NullLiteral{} -> r orig + Identifier{} -> r orig + BinaryOperator e1 op e2 -> r (BinaryOperator (recr e1) op (recr e2)) + PrefixOperator op e1 -> r (PrefixOperator op (recr e1)) + PostfixOperator e1 op -> r (PostfixOperator (recr e1) op) + BetweenOperator e1 e2 e3 -> r (BetweenOperator (recr e1) (recr e2) (recr e3)) + FunctionApplication fname args -> r (FunctionApplication fname (map recr args)) + c@CaseExpr{} -> r (CaseExpr { caseWhens = map (\(conds, res) -> (map recr conds, recr res)) (caseWhens c), + caseElse = recr <$> caseElse c + }) + c@QuantifiedComparison{} -> r (c{ qcExpr = recr (qcExpr c) }) + InExpr flag e1 predval -> r (InExpr flag (recr e1) predval) + BooleanOperatorExpr e1 op e2 -> r (BooleanOperatorExpr (recr e1) op (recr e2)) + e@ExistsExpr{} -> e + where + recr = replaceProjScalarExpr r + +-- convert group by info into extend tasks +{- +convertGroupByInfo :: GroupByInfo -> SelectItemsConvertTask -> SelectItemsConvertTask +convertGroupByInfo ginfo task = + task { taskExtenders = taskExtenders task <> gbyExtenders, + taskProjections = taskProjections tasks <> gbyProjections } + where + grouper = AttributeExtendTupleExpr "_sql_aggregate" + (RelationAtomExpr + ( + gbyExtenders = grouper : map mkAggregateExtender (aggregates groupInfo) + mkAggregateExtender sexpr = + replaceProjScalarExpr (\expr -> + case expr of + FunctionApplication fname [Identifier colName] + | fname == "sql_max" -> + FunctionApplication fname [ -- cannot make RelationalExpr here and we want to make a RelationValuedAttribute-based expression + gbyProjections = -- map mkAggregateProjection (aggregates groupInfo) +-- mkAggregateProjection expr = + -} + +-- find SQL aggregate functions and replace then with folds on attribute "_sql_aggregate" +processSQLAggregateFunctions :: AtomExpr -> AtomExpr +processSQLAggregateFunctions expr = + case expr of + AttributeAtomExpr{} -> expr + NakedAtomExpr{} -> expr + FunctionAtomExpr fname [AttributeAtomExpr attrName] () + | fname `S.member` sqlAggregateFunctions -> + FunctionAtomExpr fname + [RelationAtomExpr (Project (AttributeNames (S.singleton attrName)) (RelationValuedAttribute "_sql_aggregate"))] () + FunctionAtomExpr{} -> expr + RelationAtomExpr{} -> expr --not supported in SQL + ConstructedAtomExpr{} -> expr --not supported in SQL diff --git a/src/lib/ProjectM36/SQL/Select.hs b/src/lib/ProjectM36/SQL/Select.hs index 84c9cb6e..71117376 100644 --- a/src/lib/ProjectM36/SQL/Select.hs +++ b/src/lib/ProjectM36/SQL/Select.hs @@ -6,6 +6,7 @@ import Data.Functor.Foldable.TH import Codec.Winery import GHC.Generics import Control.DeepSeq +import Data.Hashable data Query = QuerySelect Select | QueryValues [[ScalarExpr]] | @@ -21,6 +22,8 @@ data Select = Select { distinctness :: Maybe Distinctness, deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryRecord Select +instance Hashable Select + emptySelect :: Select emptySelect = Select { distinctness = Nothing, projectionClause = [], @@ -34,28 +37,36 @@ data WithClause = WithClause { isRecursive :: Bool, withExprs :: NE.NonEmpty WithExpr } deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryRecord WithClause + deriving Hashable data WithExpr = WithExpr WithExprAlias Select deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant WithExpr + deriving Hashable newtype WithExprAlias = WithExprAlias Text deriving (Show, Eq, Generic) deriving Serialise via WineryVariant WithExprAlias - deriving newtype NFData + deriving newtype NFData + deriving anyclass Hashable data InFlag = In | NotIn deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant InFlag + deriving Hashable data ComparisonOperator = OpLT | OpGT | OpGTE | OpEQ | OpNE | OpLTE deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant ComparisonOperator +instance Hashable ComparisonOperator + data QuantifiedComparisonPredicate = QCAny | QCSome | QCAll deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant QuantifiedComparisonPredicate +instance Hashable QuantifiedComparisonPredicate + data TableRef = SimpleTableRef TableName | InnerJoinTableRef TableRef JoinCondition | RightOuterJoinTableRef TableRef JoinCondition @@ -67,6 +78,7 @@ data TableRef = SimpleTableRef TableName | QueryTableRef Select deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant TableRef + deriving Hashable -- distinguish between projection attributes which may include an asterisk and scalar expressions (such as in a where clause) where an asterisk is invalid type ProjectionScalarExpr = ScalarExprBase ColumnProjectionName @@ -105,33 +117,42 @@ data ScalarExprBase n = | ExistsExpr Select deriving (Show, Eq, Generic, NFData) +instance (Hashable n, Eq n) => Hashable (ScalarExprBase n) + data BoolOp = AndOp | OrOp deriving (Eq, Show, Generic, NFData) deriving Serialise via WineryVariant BoolOp + deriving Hashable data InPredicateValue = InList [ScalarExpr] | InQueryExpr Select | InScalarExpr ScalarExpr deriving (Eq, Show, Generic, NFData) deriving Serialise via WineryVariant InPredicateValue + deriving Hashable -data GroupByExpr = Group ProjectionScalarExpr +data GroupByExpr = GroupByExpr ProjectionScalarExpr deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant GroupByExpr + deriving Hashable -data HavingExpr = Having ScalarExpr +data HavingExpr = HavingExpr ScalarExpr deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant HavingExpr + deriving Hashable data SortExpr = SortExpr ScalarExpr (Maybe Direction) (Maybe NullsOrder) deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant SortExpr + deriving Hashable data Direction = Ascending | Descending deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant Direction + deriving Hashable data NullsOrder = NullsFirst | NullsLast deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant NullsOrder + deriving Hashable data JoinType = InnerJoin | RightOuterJoin | LeftOuterJoin | FullOuterJoin | CrossJoin | NaturalJoin deriving (Show, Eq, Generic, NFData) @@ -140,59 +161,76 @@ data JoinType = InnerJoin | RightOuterJoin | LeftOuterJoin | FullOuterJoin | Cro data JoinCondition = JoinOn JoinOnCondition | JoinUsing [UnqualifiedColumnName] deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant JoinCondition + deriving Hashable newtype JoinOnCondition = JoinOnCondition ScalarExpr deriving (Show, Eq, Generic) deriving Serialise via WineryVariant JoinOnCondition deriving newtype NFData + deriving newtype Hashable data ColumnProjectionName = ColumnProjectionName [ProjectionName] --dot-delimited reference deriving (Show, Eq, Ord, Generic, NFData) deriving Serialise via WineryVariant ColumnProjectionName +instance Hashable ColumnProjectionName + data ProjectionName = ProjectionName Text | Asterisk deriving (Show, Eq, Ord, Generic, NFData) deriving Serialise via WineryVariant ProjectionName + deriving Hashable data ColumnName = ColumnName [Text] deriving (Show, Eq, Ord, Generic, NFData) deriving Serialise via WineryVariant ColumnName + deriving Hashable data UnqualifiedColumnName = UnqualifiedColumnName Text deriving (Show, Eq, Ord, Generic, NFData) deriving Serialise via WineryVariant UnqualifiedColumnName + deriving Hashable data TableName = TableName [Text] deriving (Show, Eq, Ord, Generic, NFData) deriving Serialise via WineryVariant TableName + deriving Hashable data OperatorName = OperatorName [Text] deriving (Show, Eq, Ord, Generic, NFData) deriving Serialise via WineryVariant OperatorName +instance Hashable OperatorName + newtype ColumnAlias = ColumnAlias { unColumnAlias :: Text } deriving (Show, Eq, Ord, Generic) deriving Serialise via WineryVariant ColumnAlias deriving newtype NFData + deriving newtype Hashable newtype TableAlias = TableAlias { unTableAlias :: Text } deriving (Show, Eq, Ord, Generic) deriving Serialise via WineryVariant TableAlias deriving newtype (Monoid, Semigroup, NFData) + deriving newtype Hashable newtype FuncName = FuncName [Text] deriving (Show, Eq, Generic, Ord) deriving Serialise via WineryVariant FuncName deriving newtype NFData +instance Hashable FuncName + data Distinctness = Distinct | All deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant Distinctness +instance Hashable Distinctness + newtype RestrictionExpr = RestrictionExpr ScalarExpr deriving (Show, Eq, Generic) deriving Serialise via WineryVariant RestrictionExpr deriving newtype NFData + deriving newtype Hashable data TableExpr = TableExpr { fromClause :: [TableRef], @@ -205,6 +243,7 @@ data TableExpr = } deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryRecord TableExpr + deriving Hashable emptyTableExpr :: TableExpr emptyTableExpr = TableExpr { fromClause = [], diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 7cb5e37b..c9f4eb74 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -50,7 +50,7 @@ testSelect = TestCase $ do (tgraph,transId) <- freshTransactionGraph sqlDBContext (sess, conn) <- dateExamplesConnection emptyNotificationCallback - let readTests = [{- + let readTests = [ -- simple relvar ("SELECT * FROM s", "(s)", "(s)"), -- simple projection @@ -149,17 +149,17 @@ testSelect = TestCase $ do ("SELECT abs(-4)", "((relation{}{tuple{}}:{attr_1:=sql_abs(sql_negate(4))}){attr_1})", "(relation{tuple{attr_1 SQLJust 4}})" - ),-} + ), -- where not exists -- group by ("SELECT city,max(status) FROM s GROUP BY city", - "((((s{city,status}) group ({status} as sub)) : {status2:=sql_max(@sub)}){city,status2} rename {status2 as status})", - "(relation{city Text, status Integer}{tuple{city \"London\", status 20}, tuple{city \"Paris\", status 30}, tuple{city \"Athens\", status 30}})" - ){-, + "((s group ({all but city} as `_sql_aggregate`) : {attr_2:=sql_max(@`_sql_aggregate`{status})}){city,attr_2})", + "(relation{city Text, attr_2 SQLNullable Integer}{tuple{city \"London\", attr_2 SQLJust 20}, tuple{city \"Paris\", attr_2 SQLJust 30}, tuple{city \"Athens\", attr_2 SQLJust 30}})" + ), -- group by with aggregate column alias - ("SELECT city,max(status) as max FROM s GROUP BY city", -... -), + ("SELECT city,max(status) as status FROM s GROUP BY city", + "((s group ({all but city} as `_sql_aggregate`) : {status:=sql_max(@`_sql_aggregate`{status})}){city,status})", + "(relation{city Text, status SQLNullable Integer}{tuple{city \"London\", status SQLJust 20}, tuple{city \"Paris\", status SQLJust 30}, tuple{city \"Athens\", status SQLJust 30}})"), -- group by having -- limit -- case when @@ -223,7 +223,10 @@ testSelect = TestCase $ do "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust False}})"), ("SELECT NULL AND TRUE", "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNull,True)}){attr_1})", - "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})")-} + "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})") + -- CASE WHEN +-- ("SELECT CASE WHEN true THEN 'test' ELSE 'fail'", + ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just sqlDBContext, From 9c7b8613736b06246c612d125e02b5db039932f8 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 5 May 2024 01:06:32 -0400 Subject: [PATCH 077/170] fix sql_equals requiring either both nullable args or both naked args having filtering works --- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 35 ++++++++----- src/lib/ProjectM36/SQL/Convert.hs | 65 +++++++++++++++--------- src/lib/ProjectM36/SQL/Select.hs | 2 +- test/SQL/InterpreterTest.hs | 4 ++ 4 files changed, 70 insertions(+), 36 deletions(-) diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index 616cb484..fb09b8f7 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -33,9 +33,9 @@ nullAtomFunctions = HS.fromList [ Function { funcName = "sql_equals", funcType = [TypeVariableType "a", - TypeVariableType "a", + TypeVariableType "b", -- either type could be SQLNullable or a NakedAtom nullAtomType BoolAtomType], - funcBody = FunctionBuiltInBody nullEq + funcBody = FunctionBuiltInBody sqlEquals }, Function { funcName = "sql_and", @@ -78,15 +78,7 @@ nullAtomFunctions = HS.fromList [ funcBody = FunctionBuiltInBody sqlMax } ] <> sqlBooleanIntegerFunctions - where - sqlNull typ = ConstructedAtom "SQLNull" typ [] - sqlNullable val typ = ConstructedAtom "SQLJust" (nullAtomType typ) [val] - nullEq :: AtomFunctionBodyType - nullEq (a@(ConstructedAtom _ typA argsA) : b@(ConstructedAtom _ _ argsB) : []) - | isNull a || isNull b = pure $ sqlNull typA - | otherwise = pure $ sqlNullable (BoolAtom $ argsA == argsB) BoolAtomType - nullEq [a,b] | atomTypeForAtom a == atomTypeForAtom b = pure (sqlNullable (BoolAtom (a == b)) BoolAtomType) - nullEq _other = Left AtomFunctionTypeMismatchError + sqlBooleanIntegerFunctions :: HS.HashSet AtomFunction sqlBooleanIntegerFunctions = HS.fromList $ @@ -233,4 +225,23 @@ sqlNullableIntegerToMaybe (ConstructedAtom "SQLJust" aType [IntegerAtom i]) | aT sqlNullableIntegerToMaybe (ConstructedAtom "SQLNull" aType []) | aType == nullAtomType IntegerAtomType = Nothing sqlNullableIntegerToMaybe _ = Nothing - +-- check that types check out- Int and SQLNullable Int are OK, Int and SQLNullable Text are not OK +sqlEqualsTypes :: Atom -> Atom -> Bool +sqlEqualsTypes a b = underlyingType a == underlyingType b + where + underlyingType (ConstructedAtom "SQLNull" (ConstructedAtomType "SQLNullable" typmap) []) | M.size typmap == 1 = snd (head (M.assocs typmap)) + underlyingType (ConstructedAtom "SQLJust" (ConstructedAtomType "SQLNullable" typmap) _args) | M.size typmap == 1 = snd (head (M.assocs typmap)) + underlyingType atom = atomTypeForAtom atom + +sqlEquals :: AtomFunctionBodyType +sqlEquals [a,b] | sqlEqualsTypes a b = + case (maybeNullAtom a, maybeNullAtom b) of + (Nothing, _) -> pure $ nullAtom BoolAtomType Nothing + (_, Nothing) -> pure $ nullAtom BoolAtomType Nothing + (Just a', Just b') -> pure $ nullAtom BoolAtomType (Just (BoolAtom $ a' == b')) + where + maybeNullAtom (ConstructedAtom "SQLJust" (ConstructedAtomType "SQLNullable" _) [atom]) = Just atom + maybeNullAtom (ConstructedAtom "SQLNull" _ []) = Nothing + maybeNullAtom other = Just other +sqlEquals _other = Left AtomFunctionTypeMismatchError + diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index e8dfc747..4f769b19 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -570,11 +570,11 @@ convertSelect typeF sel = do Just tExpr -> convertTableExpr typeF' tExpr -- traceShowM ("table aliases", tAliasMap) let explicitWithF = if null wExprs then id else With wExprs - groupByExprs = case tableExpr sel of - Nothing -> [] - Just texpr -> groupByClause texpr + (groupByExprs, havingExpr) = case tableExpr sel of + Nothing -> ([],Nothing) + Just texpr -> (groupByClause texpr, havingClause texpr) -- convert projection using table alias map to resolve column names - projF <- convertProjection typeF' (projectionClause sel) groupByExprs + projF <- convertProjection typeF' (projectionClause sel) groupByExprs havingExpr -- add with clauses withAssocs <- tableAliasesAsWithNameAssocs let withF = case withAssocs of @@ -613,7 +613,7 @@ convertSubSelect typeF sel = do -- traceShowM ("convertSubSelect"::String, colMap) let explicitWithF = if null wExprs then id else With wExprs -- convert projection using table alias map to resolve column names - projF <- convertProjection typeF' (projectionClause sel) [] -- the projection can only project on attributes from the subselect table expression + projF <- convertProjection typeF' (projectionClause sel) [] Nothing -- the projection can only project on attributes from the subselect table expression -- add with clauses withAssocs <- tableAliasesAsWithNameAssocs let withF = case withAssocs of @@ -677,10 +677,10 @@ convertSelectItem typeF acc (c,selItem) = _ -> expr-} -convertProjection :: TypeForRelExprF -> [SelectItem] -> [GroupByExpr] -> ConvertM (RelationalExpr -> RelationalExpr) -convertProjection typeF selItems groupBys = do +convertProjection :: TypeForRelExprF -> [SelectItem] -> [GroupByExpr] -> Maybe HavingExpr -> ConvertM (RelationalExpr -> RelationalExpr) +convertProjection typeF selItems groupBys havingExpr = do -- traceShowM ("convertProjection", selItems, groupBys) - groupInfo <- convertGroupBy typeF groupBys selItems + groupInfo <- convertGroupBy typeF groupBys havingExpr selItems -- traceShowM ("convertProjection grouping"::String, groupInfo) -- attrName' (Just (ColumnAlias nam)) _ = nam -- attrName' Nothing c = "attr_" <> T.pack (show c) @@ -692,6 +692,18 @@ convertProjection typeF selItems groupBys = do (S.fromList (map fst (nonAggregates groupInfo)))) "_sql_aggregate" else pure id + let coalesceBoolF expr = FunctionAtomExpr "sql_coalesce_bool" [expr] () + fGroupHavingExtend <- + case havingRestriction groupInfo of + Nothing -> pure id + Just sexpr -> do + convertedAtomExpr <- convertProjectionScalarExpr typeF sexpr + let atomExpr = processSQLAggregateFunctions convertedAtomExpr + pure $ Extend (AttributeExtendTupleExpr "_sql_having" (coalesceBoolF atomExpr)) + let fGroupRestriction = case havingRestriction groupInfo of + Nothing -> id + Just _ -> + Restrict (AttributeEqualityPredicate "_sql_having" (NakedAtomExpr (BoolAtom True))) --apply projections fProjection <- if S.null (taskProjections task) then pure id @@ -715,7 +727,7 @@ convertProjection typeF selItems groupBys = do oldName <- convertColumnProjectionName qProjName pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) let fRenames = if S.null renamesSet then id else Rename renamesSet - pure (fProjection . fExtended . fRenames . fGroup) + pure (fGroupRestriction . fProjection . fGroupHavingExtend . fExtended . fRenames . fGroup) convertUnqualifiedColumnName :: UnqualifiedColumnName -> AttributeName convertUnqualifiedColumnName (UnqualifiedColumnName nam) = nam @@ -1078,8 +1090,6 @@ lookupFunc qname = ("max", f "sql_max") ] -sqlAggregateFunctions :: S.Set FunctionName -sqlAggregateFunctions = S.fromList ["sql_max", "sql_min", "sql_avg"] -- | Used in join condition detection necessary for renames to enable natural joins. commonAttributeNames :: TypeForRelExprF -> RelationalExpr -> RelationalExpr -> ConvertM (S.Set AttributeName, S.Set AttributeName, S.Set AttributeName) @@ -1307,8 +1317,8 @@ after: Rename (fromList [("status2","status")]) (Project (AttributeNames (fromLi -- (s group ({all but city} as sub): {maxstatus:=max(@sub{status})}){city,maxstatus} -- select city,max(status) from s group by city; -convertGroupBy :: TypeForRelExprF -> [GroupByExpr] -> [SelectItem] -> ConvertM GroupByInfo -convertGroupBy _typeF groupBys sqlProjection = do +convertGroupBy :: TypeForRelExprF -> [GroupByExpr] -> Maybe HavingExpr -> [SelectItem] -> ConvertM GroupByInfo +convertGroupBy _typeF groupBys mHavingExpr sqlProjection = do --first, check that projection includes an aggregate, otherwise, there's no point --find aggregate functions at the top-level (including within other functions such as 1+max(x)), and refocus them on the group attribute projected on the aggregate target -- do we need an operator to apply a relexpr to a subrelation? For example, it would be useful to apply a projection across all the subrelations, and types are maintained @@ -1348,15 +1358,19 @@ convertGroupBy _typeF groupBys sqlProjection = do if containsAggregate projExpr then pure (info { aggregates = projExpr : aggregates info }) else - pure info + pure info groups1 <- foldM collectGroupByInfo emptyGroupByInfo groupBys groups2 <- foldM collectNonGroupByInfo groups1 sqlProjection + let groups3 = case mHavingExpr of + Just (HavingExpr sexpr) -> groups2 { havingRestriction = Just sexpr } + Nothing -> groups2 + -- perform some validation {- let sqlProj = HS.fromList (map fst sqlProjection) groupByProj = HS.fromList (aggregates groups2 <> map fst (nonAggregates groups2)) diff = HS.difference sqlProj groupByProj if HS.null diff then-} - pure groups2 + pure groups3 {- else throwSQLE (GroupByColumnNotReferencedInGroupByError (HS.toList diff))-} @@ -1366,18 +1380,24 @@ data GroupByItem = AggGroupByItem ProjectionScalarExpr GroupByExpr | NonAggGroupByItem ProjectionScalarExpr GroupByExpr deriving (Show, Eq) +-- | Validated "group by" and "having" data data GroupByInfo = GroupByInfo { aggregates :: [ProjectionScalarExpr], -- ^ mentioned in group by clause and uses aggregation - nonAggregates :: [(AttributeName, GroupByExpr)] -- ^ mentioned in group by clause by not aggregations + nonAggregates :: [(AttributeName, GroupByExpr)], -- ^ mentioned in group by clause by not aggregations + havingRestriction :: Maybe ProjectionScalarExpr } deriving (Show, Eq) emptyGroupByInfo :: GroupByInfo -emptyGroupByInfo = GroupByInfo { aggregates = [], nonAggregates = [] } +emptyGroupByInfo = GroupByInfo { aggregates = [], nonAggregates = [], havingRestriction = Nothing } -aggregateFunctions :: S.Set FuncName -aggregateFunctions = S.fromList $ map (FuncName . (:[])) ["max", "min", "sum"] +aggregateFunctions :: [(FuncName, FunctionName)] +aggregateFunctions = [(FuncName ["max"], "sql_max"), + (FuncName ["min"], "sql_min"), + (FuncName ["sum"], "sql_sum")] +isAggregateFunction :: FuncName -> Bool +isAggregateFunction fname = fname `elem` map fst aggregateFunctions containsAggregate :: ProjectionScalarExpr -> Bool containsAggregate expr = @@ -1392,7 +1412,7 @@ containsAggregate expr = PrefixOperator op e1 -> containsAggregate e1 || opAgg op PostfixOperator e1 op -> containsAggregate e1 || opAgg op BetweenOperator e1 e2 e3 -> containsAggregate e1 || containsAggregate e2 || containsAggregate e3 - FunctionApplication fname args -> funcAgg fname || or (map containsAggregate args) + FunctionApplication fname args -> isAggregateFunction fname || or (map containsAggregate args) c@CaseExpr{} -> or (cElse : concatMap (\(whens, res) -> containsAggregate res : map containsAggregate whens) (caseWhens c)) where cElse = case caseElse c of @@ -1404,7 +1424,6 @@ containsAggregate expr = ExistsExpr{} -> False where opAgg _opName = False - funcAgg fname = fname `S.member` aggregateFunctions -- | Returns True iff a projection scalar expr within a larger expression. Used for group by aggregation validation. containsProjScalarExpr :: ProjectionScalarExpr -> ProjectionScalarExpr -> Bool @@ -1489,9 +1508,9 @@ processSQLAggregateFunctions expr = AttributeAtomExpr{} -> expr NakedAtomExpr{} -> expr FunctionAtomExpr fname [AttributeAtomExpr attrName] () - | fname `S.member` sqlAggregateFunctions -> + | fname `elem` map snd aggregateFunctions -> FunctionAtomExpr fname [RelationAtomExpr (Project (AttributeNames (S.singleton attrName)) (RelationValuedAttribute "_sql_aggregate"))] () - FunctionAtomExpr{} -> expr + FunctionAtomExpr fname args () -> FunctionAtomExpr fname (map processSQLAggregateFunctions args) () RelationAtomExpr{} -> expr --not supported in SQL ConstructedAtomExpr{} -> expr --not supported in SQL diff --git a/src/lib/ProjectM36/SQL/Select.hs b/src/lib/ProjectM36/SQL/Select.hs index 71117376..b38fce73 100644 --- a/src/lib/ProjectM36/SQL/Select.hs +++ b/src/lib/ProjectM36/SQL/Select.hs @@ -134,7 +134,7 @@ data GroupByExpr = GroupByExpr ProjectionScalarExpr deriving Serialise via WineryVariant GroupByExpr deriving Hashable -data HavingExpr = HavingExpr ScalarExpr +data HavingExpr = HavingExpr ProjectionScalarExpr deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant HavingExpr deriving Hashable diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index c9f4eb74..916f21b0 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -160,6 +160,10 @@ testSelect = TestCase $ do ("SELECT city,max(status) as status FROM s GROUP BY city", "((s group ({all but city} as `_sql_aggregate`) : {status:=sql_max(@`_sql_aggregate`{status})}){city,status})", "(relation{city Text, status SQLNullable Integer}{tuple{city \"London\", status SQLJust 20}, tuple{city \"Paris\", status SQLJust 30}, tuple{city \"Athens\", status SQLJust 30}})"), + -- aggregate without grouping + ("SELECT max(status) as status FROM s", + "(((true:{status:=s{status}}):{max:=max(@status)}){max})", + "(relation{status SQLNullable Integer}{tuple{status SQLJust 30}})") -- group by having -- limit -- case when From 2c655392fa6c5f64c81d0c47ec19e3e182cc0252 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 5 May 2024 18:42:33 -0400 Subject: [PATCH 078/170] aggregate without group by working tests passing checkpoint --- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 5 ++++- src/lib/ProjectM36/RelationalExpression.hs | 2 +- src/lib/ProjectM36/SQL/Convert.hs | 7 +++++-- test/SQL/InterpreterTest.hs | 4 ++-- 4 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index fb09b8f7..d1014675 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -205,7 +205,10 @@ sqlMax [RelationAtom relIn] = case oneTuple relIn of Nothing -> pure $ nullAtom IntegerAtomType Nothing -- SQL max of empty table is NULL Just oneTup -> - pure $ relFold (\tupIn acc -> nullMax acc (newVal tupIn)) (newVal oneTup) relIn + if atomTypeForAtom (newVal oneTup) /= IntegerAtomType then + Left AtomFunctionTypeMismatchError + else + pure $ relFold (\tupIn acc -> nullMax acc (newVal tupIn)) (newVal oneTup) relIn where newVal tupIn = tupleAtoms tupIn V.! 0 nullMax acc nextVal = diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index 38a03139..fba9858f 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -880,7 +880,7 @@ evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName' arguments tid) = do lift $ except (atomTypeVerify expType actType)) zippedArgs evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments case evalAtomFunction func evaldArgs of - Left err -> traceShow ("evalGraphrefAtomExpr"::String, funcName', arguments) $ throwError (AtomFunctionUserError err) + Left err -> throwError (AtomFunctionUserError err) Right result -> do --validate that the result matches the expected type _ <- lift $ except (atomTypeVerify (last (funcType func)) (atomTypeForAtom result)) diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 4f769b19..b34c9d10 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -687,7 +687,10 @@ convertProjection typeF selItems groupBys havingExpr = do task <- foldM (convertSelectItem typeF) emptyTask (zip [1::Int ..] selItems) -- traceShowM ("convertProjection task"::String, task) -- SQL supports only one grouping at a time, but multiple aggregations, so we create the group as attribute "_sql_aggregate" and the aggregations as fold projections on it - fGroup <- if not (null (nonAggregates groupInfo)) then + fGroup <- if not (null (nonAggregates groupInfo)) || + (null (nonAggregates groupInfo) && not (null (aggregates groupInfo))) + -- special case: SELECT max(status) FROM city- handle aggregations without GROUP BY + then pure $ Group (InvertedAttributeNames (S.fromList (map fst (nonAggregates groupInfo)))) "_sql_aggregate" else @@ -1384,7 +1387,7 @@ data GroupByItem = AggGroupByItem ProjectionScalarExpr GroupByExpr | data GroupByInfo = GroupByInfo { aggregates :: [ProjectionScalarExpr], -- ^ mentioned in group by clause and uses aggregation nonAggregates :: [(AttributeName, GroupByExpr)], -- ^ mentioned in group by clause by not aggregations - havingRestriction :: Maybe ProjectionScalarExpr + havingRestriction :: Maybe ProjectionScalarExpr } deriving (Show, Eq) diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 916f21b0..ceb2aae0 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -162,8 +162,8 @@ testSelect = TestCase $ do "(relation{city Text, status SQLNullable Integer}{tuple{city \"London\", status SQLJust 20}, tuple{city \"Paris\", status SQLJust 30}, tuple{city \"Athens\", status SQLJust 30}})"), -- aggregate without grouping ("SELECT max(status) as status FROM s", - "(((true:{status:=s{status}}):{max:=max(@status)}){max})", - "(relation{status SQLNullable Integer}{tuple{status SQLJust 30}})") + "(((s group ({all but } as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } )}){ status })", + "(relation{status SQLNullable Integer}{tuple{status SQLJust 30}})"), -- group by having -- limit -- case when From ecf03356e7f43f581dc7bb81d8bd58cd0641bd08 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 5 May 2024 23:03:54 -0400 Subject: [PATCH 079/170] all tests pass checkpoint fix bool parser to parse to NakedAtomExpr instead of ConstructedAtomExpr --- .../ProjectM36/Server/RemoteCallTypes/Json.hs | 67 +++++++++++++++++++ .../TutorialD/Interpreter/RelationalExpr.hs | 19 ++++-- src/bin/TutorialD/Interpreter/Types.hs | 6 +- src/lib/ProjectM36/SQL/Convert.hs | 17 +++-- test/SQL/InterpreterTest.hs | 3 + test/TransactionGraph/Automerge.hs | 2 - test/TutorialD/Interpreter/TestBase.hs | 1 - test/TutorialD/PrinterTest.hs | 2 +- 8 files changed, 100 insertions(+), 17 deletions(-) diff --git a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs index df140aa9..b3df3146 100644 --- a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +++ b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs @@ -224,4 +224,71 @@ instance FromJSON AtomFunctionError instance ToJSON WithNameExpr instance FromJSON WithNameExpr +instance ToJSON (ScalarExprBase ColumnProjectionName) +instance FromJSON (ScalarExprBase ColumnProjectionName) +instance ToJSON OperatorName +instance FromJSON OperatorName + +instance ToJSON BoolOp +instance FromJSON BoolOp + +instance ToJSON InPredicateValue +instance FromJSON InPredicateValue + +instance ToJSON Select +instance FromJSON Select + +instance ToJSON InFlag +instance FromJSON InFlag + +instance ToJSON QuantifiedComparisonPredicate +instance FromJSON QuantifiedComparisonPredicate + +instance ToJSON ComparisonOperator +instance FromJSON ComparisonOperator + +instance ToJSON (ScalarExprBase ColumnName) +instance FromJSON (ScalarExprBase ColumnName) + +instance ToJSON WithClause +instance FromJSON WithClause + +instance ToJSON Distinctness +instance FromJSON Distinctness + +instance ToJSON TableExpr +instance FromJSON TableExpr + +instance ToJSON WithExpr +instance FromJSON WithExpr + +instance ToJSON SortExpr +instance FromJSON SortExpr + +instance ToJSON HavingExpr +instance FromJSON HavingExpr + +instance ToJSON GroupByExpr +instance FromJSON GroupByExpr + +instance ToJSON RestrictionExpr +instance FromJSON RestrictionExpr + +instance ToJSON TableRef +instance FromJSON TableRef + +instance ToJSON WithExprAlias +instance FromJSON WithExprAlias + +instance ToJSON Direction +instance FromJSON Direction + +instance ToJSON JoinCondition +instance FromJSON JoinCondition + +instance ToJSON NullsOrder +instance FromJSON NullsOrder + +instance ToJSON JoinOnCondition +instance FromJSON JoinOnCondition diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs index 09662043..e35c8844 100644 --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -208,6 +208,7 @@ atomExprP = consumeAtomExprP True consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a) consumeAtomExprP consume = try functionAtomExprP <|> + boolAtomExprP <|> -- we do this before the constructed atom parser to consume True and False try (parens (constructedAtomExprP True)) <|> constructedAtomExprP consume <|> relationalAtomExprP <|> @@ -255,14 +256,18 @@ doubleAtomP = DoubleAtom <$> float integerAtomP :: Parser Atom integerAtomP = IntegerAtom <$> integer +boolP :: Parser Bool +boolP = + (chunk "True" >> spaceConsumer >> pure True) <|> + (chunk "False" >> spaceConsumer >> pure False) + boolAtomP :: Parser Atom -boolAtomP = do - v <- identifier - if v == "True" || v == "False" then - pure $ BoolAtom (v == "t") - else - fail "invalid boolAtom" - +boolAtomP = + BoolAtom <$> boolP + +boolAtomExprP :: Parser (AtomExprBase a) +boolAtomExprP = + NakedAtomExpr <$> boolAtomP relationAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) relationAtomExprP = RelationAtomExpr <$> makeRelationP diff --git a/src/bin/TutorialD/Interpreter/Types.hs b/src/bin/TutorialD/Interpreter/Types.hs index 7d3370e6..50378d1f 100644 --- a/src/bin/TutorialD/Interpreter/Types.hs +++ b/src/bin/TutorialD/Interpreter/Types.hs @@ -4,6 +4,7 @@ import ProjectM36.Base import ProjectM36.Interpreter import Text.Megaparsec import TutorialD.Interpreter.Base +import Control.Monad class RelationalMarkerExpr a where parseMarkerP :: Parser a @@ -15,7 +16,10 @@ typeConstructorNameP :: Parser TypeConstructorName typeConstructorNameP = capitalizedIdentifier dataConstructorNameP :: Parser DataConstructorName -dataConstructorNameP = capitalizedIdentifier +dataConstructorNameP = try $ do + ident <- capitalizedIdentifier + when (ident `elem` ["True", "False"]) $ failure Nothing mempty --don't parse True or False as ConstructedAtoms (use NakedAtoms instead) + pure ident attributeNameP :: Parser AttributeName attributeNameP = try uncapitalizedIdentifier <|> quotedIdentifier diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index b34c9d10..ade78115 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -835,8 +835,10 @@ convertScalarExpr typeF expr = do IntegerLiteral i -> naked (IntegerAtom i) DoubleLiteral d -> naked (DoubleAtom d) StringLiteral s -> naked (TextAtom s) - BooleanLiteral True -> pure $ ConstructedAtomExpr "True" [] () - BooleanLiteral False -> pure $ ConstructedAtomExpr "False" [] () + BooleanLiteral True -> naked (BoolAtom True) + -- pure $ ConstructedAtomExpr "True" [] () + BooleanLiteral False -> naked (BoolAtom False) + --pure $ ConstructedAtomExpr "False" [] () -- we don't have enough type context with a cast, so we default to text NullLiteral -> pure $ ConstructedAtomExpr "SQLNull" [] () Identifier i -> do @@ -859,8 +861,12 @@ convertProjectionScalarExpr typeF expr = do IntegerLiteral i -> naked (IntegerAtom i) DoubleLiteral d -> naked (DoubleAtom d) StringLiteral s -> naked (TextAtom s) - BooleanLiteral True -> pure $ ConstructedAtomExpr "True" [] () - BooleanLiteral False -> pure $ ConstructedAtomExpr "False" [] () + BooleanLiteral True -> + naked (BoolAtom True) + --pure $ ConstructedAtomExpr "True" [] () + BooleanLiteral False -> + naked (BoolAtom False) + --pure $ ConstructedAtomExpr "False" [] () NullLiteral -> pure $ ConstructedAtomExpr "SQLNull" [] () Identifier i -> AttributeAtomExpr <$> convertColumnProjectionName i @@ -1052,7 +1058,8 @@ joinTableRef typeF rvA (_c,tref) = do new_name joinName = firstAvailableName (1::Int) allAttrs extender = AttributeExtendTupleExpr joinName (FunctionAtomExpr "sql_coalesce_bool" [joinRe] ()) - joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) + --joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) + joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (NakedAtomExpr (BoolAtom True))) projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA)))) other -> throwSQLE $ NotSupportedError ("join: " <> T.pack (show other)) diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index ceb2aae0..2fd62854 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -165,6 +165,9 @@ testSelect = TestCase $ do "(((s group ({all but } as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } )}){ status })", "(relation{status SQLNullable Integer}{tuple{status SQLJust 30}})"), -- group by having + ("select city,max(status) as status from s group by city having max(status)=30", + "((((s group ({all but city} as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } ), `_sql_having`:=sql_coalesce_bool( sql_equals( sql_max( (@`_sql_aggregate`){ status } ), 30 ) )}){ city, status }) where `_sql_having`=True)", + "(relation{city Text,status SQLNullable Integer}{tuple{city \"Athens\",status SQLJust 30},tuple{city \"Paris\",status SQLJust 30}})"), -- limit -- case when -- union diff --git a/test/TransactionGraph/Automerge.hs b/test/TransactionGraph/Automerge.hs index d2d71031..404f5d24 100644 --- a/test/TransactionGraph/Automerge.hs +++ b/test/TransactionGraph/Automerge.hs @@ -1,7 +1,5 @@ import Test.HUnit import ProjectM36.Client -import ProjectM36.Interpreter -import ProjectM36.DatabaseContext import ProjectM36.Relation import qualified Data.Set as S import TutorialD.Interpreter.TestBase diff --git a/test/TutorialD/Interpreter/TestBase.hs b/test/TutorialD/Interpreter/TestBase.hs index 5a70a4e2..79933b8c 100644 --- a/test/TutorialD/Interpreter/TestBase.hs +++ b/test/TutorialD/Interpreter/TestBase.hs @@ -2,7 +2,6 @@ module TutorialD.Interpreter.TestBase where import ProjectM36.Client import ProjectM36.Interpreter import TutorialD.Interpreter -import TutorialD.Interpreter.Base import ProjectM36.DateExamples import ProjectM36.DatabaseContext import Test.HUnit diff --git a/test/TutorialD/PrinterTest.hs b/test/TutorialD/PrinterTest.hs index becc5c26..4e7fccfe 100644 --- a/test/TutorialD/PrinterTest.hs +++ b/test/TutorialD/PrinterTest.hs @@ -16,7 +16,7 @@ testList = TestList [ testPretty "true:{a:=1, b:=1}" (Extend (AttributeExtendTupleExpr "b" (NakedAtomExpr (IntegerAtom 1))) (Extend (AttributeExtendTupleExpr "a" (NakedAtomExpr (IntegerAtom 1))) (RelationVariable "true" ()))), testPretty "relation{tuple{a fromGregorian(2014, 2, 4)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "fromGregorian" [NakedAtomExpr (IntegerAtom 2014),NakedAtomExpr (IntegerAtom 2),NakedAtomExpr (IntegerAtom 4)] ())])])), testPretty "relation{tuple{a bytestring(\"dGVzdGRhdGE=\")}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "bytestring" [NakedAtomExpr (TextAtom "dGVzdGRhdGE=")] ())])])), - testPretty "relation{tuple{a True}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",ConstructedAtomExpr "True" [] ())])])), + testPretty "relation{tuple{a True}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (BoolAtom True))])])), testPretty "relation{tuple{a Cons 4 (Cons 5 Empty)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 4),ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 5),ConstructedAtomExpr "Empty" [] ()] ()] ())])])), testPretty "relation{a Int, b Text, c Bool}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (ADTypeConstructor "Int" []) (),AttributeAndTypeNameExpr "b" (ADTypeConstructor "Text" []) (),AttributeAndTypeNameExpr "c" (ADTypeConstructor "Bool" []) ()]) (TupleExprs () [])), testPretty "relation{a relation{b Int}}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (RelationAtomTypeConstructor [AttributeAndTypeNameExpr "b" (ADTypeConstructor "Int" []) ()]) ()]) (TupleExprs () [])) From 5f93a27b603a9e4f6044d760b7b6aaff967e0147 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 6 May 2024 13:30:20 -0400 Subject: [PATCH 080/170] support CASE WHEN expressions in SQL support if-then-else clause in TutorialD --- src/bin/SQL/Interpreter/Select.hs | 22 +++++++++++++-- .../TutorialD/Interpreter/RelationalExpr.hs | 14 +++++++++- src/bin/TutorialD/Printer.hs | 1 + src/lib/ProjectM36/Base.hs | 1 + src/lib/ProjectM36/Error.hs | 1 + src/lib/ProjectM36/HashSecurely.hs | 1 + src/lib/ProjectM36/NormalizeExpr.hs | 2 ++ src/lib/ProjectM36/RelationalExpression.hs | 21 ++++++++++++++ src/lib/ProjectM36/SQL/Convert.hs | 28 +++++++++++++++---- src/lib/ProjectM36/SQL/Select.hs | 2 +- src/lib/ProjectM36/StaticOptimizer.hs | 1 + .../TransGraphRelationalExpression.hs | 2 ++ src/lib/ProjectM36/WithNameExpr.hs | 2 ++ test/SQL/InterpreterTest.hs | 9 +++--- test/TutorialD/InterpreterTest.hs | 9 +++++- 15 files changed, 102 insertions(+), 14 deletions(-) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 599774e8..207605ec 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -266,7 +266,7 @@ stringLiteralP = StringLiteral <$> stringP rest <- stringEndP pure $ T.concat [capture, "'",rest]), --quoted quote pure capture - ] + ] <* spaceConsumer nullLiteralP :: Parser (ScalarExprBase a) nullLiteralP = @@ -277,7 +277,7 @@ scalarTermP = choice [ existsP, simpleLiteralP, --,subQueryExpr --- caseExpr, + caseExprP, --,cast -- subquery, -- pseudoArgFunc, -- includes NOW, NOW(), CURRENT_USER, TRIM(...), etc. @@ -286,6 +286,24 @@ scalarTermP = choice [ ] "scalar expression" +caseExprP :: QualifiedNameP a => Parser (ScalarExprBase a) +caseExprP = do + let whenThenClause = do + reserved "when" + cond <- scalarExprP + reserved "then" + result <- scalarExprP + pure (cond, result) + elseClause = do + reserved "else" + scalarExprP + reserved "case" + conditionals <- some whenThenClause + mElse <- optional elseClause + reserved "end" + pure (CaseExpr { caseWhens = conditionals, + caseElse = mElse }) + scalarFunctionP :: QualifiedNameP a => Parser (ScalarExprBase a) scalarFunctionP = try $ diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs index e35c8844..22bd27de 100644 --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -208,10 +208,11 @@ atomExprP = consumeAtomExprP True consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a) consumeAtomExprP consume = try functionAtomExprP <|> + ifThenAtomExprP <|> boolAtomExprP <|> -- we do this before the constructed atom parser to consume True and False try (parens (constructedAtomExprP True)) <|> constructedAtomExprP consume <|> - relationalAtomExprP <|> + relationalAtomExprP <|> attributeAtomExprP <|> try nakedAtomExprP @@ -236,6 +237,17 @@ atomP = stringAtomP <|> integerAtomP <|> boolAtomP +-- Haskell-like if-then-else expression for TutorialD +ifThenAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) +ifThenAtomExprP = do + reserved "if" + ifE <- atomExprP + reserved "then" + thenE <- atomExprP + reserved "else" + elseE <- atomExprP + pure (IfThenAtomExpr ifE thenE elseE) + functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) functionAtomExprP = FunctionAtomExpr <$> functionNameP <*> parens (sepBy atomExprP comma) <*> parseMarkerP diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index b8bc64a1..f2243617 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -44,6 +44,7 @@ instance Pretty AtomExpr where pretty (NakedAtomExpr atom) = pretty atom pretty (FunctionAtomExpr atomFuncName' atomExprs _) = pretty atomFuncName' <> prettyAtomExprsAsArguments atomExprs pretty (RelationAtomExpr relExpr) = pretty relExpr + pretty (IfThenAtomExpr ifE thenE elseE) = "if" <+> pretty ifE <+> "then" <+> pretty thenE <+> "else" <+> pretty elseE pretty (ConstructedAtomExpr dName [] _) = pretty dName pretty (ConstructedAtomExpr dName atomExprs _) = pretty dName <+> hsep (map prettyAtomExpr atomExprs) diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 082f19f3..9c24ae94 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -511,6 +511,7 @@ data AtomExprBase a = AttributeAtomExpr !AttributeName | NakedAtomExpr !Atom | FunctionAtomExpr FunctionName [AtomExprBase a] a | RelationAtomExpr (RelationalExprBase a) | + IfThenAtomExpr (AtomExprBase a) (AtomExprBase a) (AtomExprBase a) | -- if, then, else ConstructedAtomExpr DataConstructorName [AtomExprBase a] a deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable) diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs index a79bac2b..c148aa0d 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -61,6 +61,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName) | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap | AtomFunctionTypeVariableResolutionError FunctionName TypeVarName | AtomFunctionTypeVariableMismatch TypeVarName AtomType AtomType + | IfThenExprExpectedBooleanError AtomType | AtomTypeNameInUseError AtomTypeName | IncompletelyDefinedAtomTypeWithConstructorError | AtomTypeNameNotInUseError AtomTypeName diff --git a/src/lib/ProjectM36/HashSecurely.hs b/src/lib/ProjectM36/HashSecurely.hs index dfc3784e..4f6f3c1e 100644 --- a/src/lib/ProjectM36/HashSecurely.hs +++ b/src/lib/ProjectM36/HashSecurely.hs @@ -142,6 +142,7 @@ instance HashBytes a => HashBytes (AtomExprBase a) where (FunctionAtomExpr fname args marker) -> hashBytesL ctx "FunctionAtomExpr" $ [SHash fname, SHash marker] <> map SHash args (RelationAtomExpr r) -> hashBytesL ctx "RelationAtomExpr" [SHash r] + (IfThenAtomExpr i t e) -> hashBytesL ctx "IfThenAtomExpr" [SHash i, SHash t, SHash e] (ConstructedAtomExpr dConsName args marker) -> hashBytesL ctx "ConstructedAtomExpr" ([SHash dConsName, SHash marker] <> map SHash args) diff --git a/src/lib/ProjectM36/NormalizeExpr.hs b/src/lib/ProjectM36/NormalizeExpr.hs index e6b724f5..9546b0f7 100644 --- a/src/lib/ProjectM36/NormalizeExpr.hs +++ b/src/lib/ProjectM36/NormalizeExpr.hs @@ -116,6 +116,8 @@ processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom processAtomExpr (FunctionAtomExpr fName atomExprs ()) = FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> askMarker processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr +processAtomExpr (IfThenAtomExpr ifE thenE elseE) = + IfThenAtomExpr <$> processAtomExpr ifE <*> processAtomExpr thenE <*> processAtomExpr elseE processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> askMarker processTupleExprs :: TupleExprs -> ProcessExprM GraphRefTupleExprs diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index fba9858f..a4e93402 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -891,6 +891,12 @@ evalGraphRefAtomExpr tupIn (RelationAtomExpr relExpr) = do let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn env relAtom <- lift $ except $ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr) pure (RelationAtom relAtom) +evalGraphRefAtomExpr tupIn (IfThenAtomExpr ifExpr thenExpr elseExpr) = do + conditional <- evalGraphRefAtomExpr tupIn ifExpr + case conditional of + BoolAtom True -> evalGraphRefAtomExpr tupIn thenExpr + BoolAtom False -> evalGraphRefAtomExpr tupIn elseExpr + otherAtom -> traceShow ("evalAtom"::String, otherAtom) $ throwError (IfThenExprExpectedBooleanError (atomTypeForAtom otherAtom)) evalGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _) | tOrF == "True" = pure (BoolAtom True) | tOrF == "False" = pure (BoolAtom False) @@ -943,6 +949,15 @@ typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName' atomArgs transId) = do typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr) pure (RelationAtomType (attributes relType)) +typeForGraphRefAtomExpr attrs (IfThenAtomExpr ifExpr thenExpr elseExpr) = do + -- ifExpr must be BoolAtomType + ifType <- typeForGraphRefAtomExpr attrs ifExpr + when (ifType /= BoolAtomType) $ throwError (IfThenExprExpectedBooleanError ifType) + -- thenExpr and elseExpr must return the same type + thenType <- typeForGraphRefAtomExpr attrs thenExpr + elseType <- typeForGraphRefAtomExpr attrs elseExpr + when (thenType /= elseType) $ throwError (AtomTypeMismatchError thenType elseType) + pure thenType -- grab the type of the data constructor, then validate that the args match the expected types typeForGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _) | tOrF `elem` ["True", "False"] = pure BoolAtomType @@ -990,6 +1005,11 @@ verifyGraphRefAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = let mergedAttrsEnv = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn) relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr) lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType)) +verifyGraphRefAtomExprTypes relIn (IfThenAtomExpr _ifExpr thenExpr elseExpr) expectedType = do + thenType <- typeForGraphRefAtomExpr (attributes relIn) thenExpr + elseType <- typeForGraphRefAtomExpr (attributes relIn) elseExpr + when (thenType /= elseType) $ throwError (AtomTypeMismatchError thenType elseType) + lift $ except $ atomTypeVerify expectedType thenType verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do cType <- typeForGraphRefAtomExpr (attributes rel) cons lift $ except $ atomTypeVerify expectedType cType @@ -1441,6 +1461,7 @@ instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where resolve (FunctionAtomExpr nam atomExprs marker) = FunctionAtomExpr nam <$> mapM resolve atomExprs <*> pure marker resolve (RelationAtomExpr expr) = RelationAtomExpr <$> resolve expr + resolve (IfThenAtomExpr ifExpr thenExpr elseExpr) = IfThenAtomExpr <$> resolve ifExpr <*> resolve thenExpr <*> resolve elseExpr resolve (ConstructedAtomExpr dConsName atomExprs marker) = ConstructedAtomExpr dConsName <$> mapM resolve atomExprs <*> pure marker diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index ade78115..143d08e2 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -31,6 +31,7 @@ import Control.Monad.Trans.State (StateT, get, put, runStateT, evalStateT) import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Trans.Class (lift) +import Data.Foldable (foldl') --import qualified Data.HashSet as HS import Debug.Trace @@ -854,6 +855,7 @@ convertScalarExpr typeF expr = do pure (func fargs') other -> throwSQLE $ NotSupportedError ("scalar expr: " <> T.pack (show other)) +-- SQL conflates projection and extension so we use the SQL context name here convertProjectionScalarExpr :: TypeForRelExprF -> ProjectionScalarExpr -> ConvertM AtomExpr convertProjectionScalarExpr typeF expr = do let naked = pure . NakedAtomExpr @@ -883,6 +885,20 @@ convertProjectionScalarExpr typeF expr = do func <- lookupOperator True op arg <- convertProjectionScalarExpr typeF sexpr pure (func [arg]) + CaseExpr conditionals mElse -> do + let coalesceBoolF expr' = FunctionAtomExpr "sql_coalesce_bool" [expr'] () + conditionals' <- mapM (\(ifExpr, thenExpr) -> do + ifE <- coalesceBoolF <$> convertProjectionScalarExpr typeF ifExpr + thenE <- convertProjectionScalarExpr typeF thenExpr + + pure (ifE, thenE) + ) conditionals + + elseExpr <- case mElse of + Nothing -> pure $ NakedAtomExpr $ nullAtom (TypeVariableType "a") Nothing --will the engine resolve this type variable? + Just expr' -> convertProjectionScalarExpr typeF expr' + let ifThenFolder acc (ifE, thenE) = IfThenAtomExpr ifE thenE acc + pure $ foldl' ifThenFolder elseExpr conditionals' other -> throwSQLE $ NotSupportedError ("projection scalar expr: " <> T.pack (show other)) convertOrderByClause :: TypeForRelExprF -> [SortExpr] -> ConvertM [AttributeOrderExpr] @@ -1151,8 +1167,8 @@ needsToRenameAllAttributes (RestrictionExpr sexpr) = PostfixOperator e1 _ -> rec' e1 BetweenOperator e1 _ e2 -> rec' e1 || rec' e2 FunctionApplication _ e1 -> or (rec' <$> e1) - CaseExpr cases else' -> or (map (\(whens, then') -> - or (map rec' whens) || rec' then' || maybe False rec' else') cases) + CaseExpr cases else' -> or (map (\(when', then') -> + rec' when' || rec' then' || maybe False rec' else') cases) QuantifiedComparison{} -> True InExpr _ sexpr'' _ -> rec' sexpr'' BooleanOperatorExpr e1 _ e2 -> rec' e1 || rec' e2 @@ -1208,6 +1224,7 @@ pushDownAttributeRename renameSet matchExpr targetExpr = x@NakedAtomExpr{} -> x FunctionAtomExpr fname args () -> FunctionAtomExpr fname (pushAtom <$> args) () RelationAtomExpr e -> RelationAtomExpr (push e) + IfThenAtomExpr ifE thenE elseE -> IfThenAtomExpr (pushAtom ifE) (pushAtom thenE) (pushAtom elseE) ConstructedAtomExpr dConsName args () -> ConstructedAtomExpr dConsName (pushAtom <$> args) () mkTableContextFromDatabaseContext :: DatabaseContext -> TransactionGraph -> Either RelationalError TableContext @@ -1423,7 +1440,7 @@ containsAggregate expr = PostfixOperator e1 op -> containsAggregate e1 || opAgg op BetweenOperator e1 e2 e3 -> containsAggregate e1 || containsAggregate e2 || containsAggregate e3 FunctionApplication fname args -> isAggregateFunction fname || or (map containsAggregate args) - c@CaseExpr{} -> or (cElse : concatMap (\(whens, res) -> containsAggregate res : map containsAggregate whens) (caseWhens c)) + c@CaseExpr{} -> or (cElse : concatMap (\(when', res) -> [containsAggregate res, containsAggregate when']) (caseWhens c)) where cElse = case caseElse c of Just e -> containsAggregate e @@ -1453,7 +1470,7 @@ containsProjScalarExpr needle haystack = PostfixOperator e1 _op -> con e1 BetweenOperator e1 e2 e3 -> con e1 || con e2 || con e3 FunctionApplication _fname args -> or (map con args) - c@CaseExpr{} -> or (cElse : concatMap (\(whens, res) -> con res : map con whens) (caseWhens c)) + c@CaseExpr{} -> or (cElse : concatMap (\(when', res) -> [con res, con when']) (caseWhens c)) where cElse = case caseElse c of Just e -> con e @@ -1480,7 +1497,7 @@ replaceProjScalarExpr r orig = PostfixOperator e1 op -> r (PostfixOperator (recr e1) op) BetweenOperator e1 e2 e3 -> r (BetweenOperator (recr e1) (recr e2) (recr e3)) FunctionApplication fname args -> r (FunctionApplication fname (map recr args)) - c@CaseExpr{} -> r (CaseExpr { caseWhens = map (\(conds, res) -> (map recr conds, recr res)) (caseWhens c), + c@CaseExpr{} -> r (CaseExpr { caseWhens = map (\(cond, res) -> (recr cond, recr res)) (caseWhens c), caseElse = recr <$> caseElse c }) c@QuantifiedComparison{} -> r (c{ qcExpr = recr (qcExpr c) }) @@ -1523,4 +1540,5 @@ processSQLAggregateFunctions expr = [RelationAtomExpr (Project (AttributeNames (S.singleton attrName)) (RelationValuedAttribute "_sql_aggregate"))] () FunctionAtomExpr fname args () -> FunctionAtomExpr fname (map processSQLAggregateFunctions args) () RelationAtomExpr{} -> expr --not supported in SQL + IfThenAtomExpr ifE thenE elseE -> IfThenAtomExpr (processSQLAggregateFunctions ifE) (processSQLAggregateFunctions thenE) (processSQLAggregateFunctions elseE) ConstructedAtomExpr{} -> expr --not supported in SQL diff --git a/src/lib/ProjectM36/SQL/Select.hs b/src/lib/ProjectM36/SQL/Select.hs index b38fce73..46a65ed8 100644 --- a/src/lib/ProjectM36/SQL/Select.hs +++ b/src/lib/ProjectM36/SQL/Select.hs @@ -102,7 +102,7 @@ data ScalarExprBase n = | PostfixOperator (ScalarExprBase n) OperatorName | BetweenOperator (ScalarExprBase n) (ScalarExprBase n) (ScalarExprBase n) | FunctionApplication FuncName [ScalarExprBase n] - | CaseExpr { caseWhens :: [([ScalarExprBase n],ScalarExprBase n)], + | CaseExpr { caseWhens :: [(ScalarExprBase n,ScalarExprBase n)], caseElse :: Maybe (ScalarExprBase n) } | QuantifiedComparison { qcExpr :: ScalarExprBase n, qcOperator :: ComparisonOperator, diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index 4e02415a..7d187b18 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -435,6 +435,7 @@ isStaticAtomExpr NakedAtomExpr{} = True isStaticAtomExpr ConstructedAtomExpr{} = True isStaticAtomExpr AttributeAtomExpr{} = False isStaticAtomExpr FunctionAtomExpr{} = False +isStaticAtomExpr IfThenAtomExpr{} = False isStaticAtomExpr RelationAtomExpr{} = False --if the projection of a join only uses the attributes from one of the expressions and there is a foreign key relationship between the expressions, we know that the join is inconsequential and can be removed diff --git a/src/lib/ProjectM36/TransGraphRelationalExpression.hs b/src/lib/ProjectM36/TransGraphRelationalExpression.hs index 1ba247b0..dd5c8544 100644 --- a/src/lib/ProjectM36/TransGraphRelationalExpression.hs +++ b/src/lib/ProjectM36/TransGraphRelationalExpression.hs @@ -127,6 +127,8 @@ processTransGraphAtomExpr (FunctionAtomExpr funcName' args tLookup) = FunctionAtomExpr funcName' <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup processTransGraphAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processTransGraphRelationalExpr expr +processTransGraphAtomExpr (IfThenAtomExpr ifE thenE elseE) = + IfThenAtomExpr <$> processTransGraphAtomExpr ifE <*> processTransGraphAtomExpr thenE <*> processTransGraphAtomExpr elseE processTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) = ConstructedAtomExpr dConsName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr diff --git a/src/lib/ProjectM36/WithNameExpr.hs b/src/lib/ProjectM36/WithNameExpr.hs index 0a39f790..ecc1d2ae 100644 --- a/src/lib/ProjectM36/WithNameExpr.hs +++ b/src/lib/ProjectM36/WithNameExpr.hs @@ -89,6 +89,8 @@ substituteWithNameMacrosAtomExpr macros atomExpr = FunctionAtomExpr fname (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid RelationAtomExpr reExpr -> RelationAtomExpr (substituteWithNameMacros macros reExpr) + IfThenAtomExpr ifE thenE elseE -> + IfThenAtomExpr (substituteWithNameMacrosAtomExpr macros ifE) (substituteWithNameMacrosAtomExpr macros thenE) (substituteWithNameMacrosAtomExpr macros elseE) ConstructedAtomExpr dconsName atomExprs tid -> ConstructedAtomExpr dconsName (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 2fd62854..9a178770 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -168,11 +168,15 @@ testSelect = TestCase $ do ("select city,max(status) as status from s group by city having max(status)=30", "((((s group ({all but city} as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } ), `_sql_having`:=sql_coalesce_bool( sql_equals( sql_max( (@`_sql_aggregate`){ status } ), 30 ) )}){ city, status }) where `_sql_having`=True)", "(relation{city Text,status SQLNullable Integer}{tuple{city \"Athens\",status SQLJust 30},tuple{city \"Paris\",status SQLJust 30}})"), - -- limit -- case when + ("SELECT city,case when city='London' then true else false end as islondon from s", + "((s:{islondon:=if sql_coalesce_bool( sql_equals( @city, \"London\" ) ) then True else False}){ city, islondon })", + "(relation{tuple{city \"London\", islondon True},tuple{city \"Paris\", islondon False},tuple{city \"Athens\", islondon False}})" + ), -- union -- intersect -- except + -- limit ("SELECT * FROM s LIMIT 10", "(s) limit 10", "(s) limit 10" @@ -231,9 +235,6 @@ testSelect = TestCase $ do ("SELECT NULL AND TRUE", "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNull,True)}){attr_1})", "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})") - -- CASE WHEN --- ("SELECT CASE WHEN true THEN 'test' ELSE 'fail'", - ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just sqlDBContext, diff --git a/test/TutorialD/InterpreterTest.hs b/test/TutorialD/InterpreterTest.hs index 9ae8c461..1cb61944 100644 --- a/test/TutorialD/InterpreterTest.hs +++ b/test/TutorialD/InterpreterTest.hs @@ -94,7 +94,8 @@ main = do testDDLHash, testShowDDL, testRegisteredQueries, - testCrossJoin + testCrossJoin, + testIfThenExpr ] simpleRelTests :: Test @@ -869,3 +870,9 @@ testCrossJoin = TestCase $ do assertBool "cross join 2 error" (isRight eActual') assertEqual "cross join 2" eExpected' eActual' +testIfThenExpr :: Test +testIfThenExpr = TestCase $ do + (session, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD session dbconn "x:=(s:{islondon:=if eq(@city,\"London\") then True else False}){city,islondon} = relation{tuple{city \"London\", islondon True},tuple{city \"Paris\",islondon False},tuple{city \"Athens\", islondon False}}" + eEqRel <- executeRelationalExpr session dbconn (RelationVariable "x" ()) + assertEqual "if-then" (Right relationTrue) eEqRel From a76c70baf3aa288147ddfa571f5a06fb4c377bb4 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 7 May 2024 01:44:37 -0400 Subject: [PATCH 081/170] add SQL union, intersect, and except query operators --- docs/tutd_cheatsheet.markdown | 1 + sql_optimizations_applied | 87 +++++++++++++++++++++++++++ src/bin/SQL/Interpreter/Select.hs | 16 ++++- src/lib/ProjectM36/Client.hs | 3 +- src/lib/ProjectM36/Error.hs | 1 + src/lib/ProjectM36/SQL/Convert.hs | 24 ++++++++ src/lib/ProjectM36/SQL/Select.hs | 7 ++- src/lib/ProjectM36/StaticOptimizer.hs | 11 +++- 8 files changed, 142 insertions(+), 8 deletions(-) create mode 100644 sql_optimizations_applied diff --git a/docs/tutd_cheatsheet.markdown b/docs/tutd_cheatsheet.markdown index acc28ab8..016b3fa3 100644 --- a/docs/tutd_cheatsheet.markdown +++ b/docs/tutd_cheatsheet.markdown @@ -18,6 +18,7 @@ Relational expressions query database state without being able to change it. |`:showexpr s antijoin sp`|Display the result of all tuples in `s` which do not match appear in the result of `s semijoin sp`| |`:showexpr s union s`| Display the result of `s` unioned with itself (which is equivalent to `s`)| |`:showexpr s:{status2:=add(10,@status)}`| Display the result of extending the `s` relation variable with a new attribute which adds 10 to each `status` attribute| +|`:showexpr (s:{islondon:=if eq(@city,"London") then True else False}){city,islondon}`| Display the result of relation variable `s` extended with a new attribute `islondon` which is the result of a conditional. | |`:showexpr s where lt(@status, 30)`|Display the result of `s` where the `status` is less than 30.| |`:showexpr s relwhere (p{})`|Display the result of `s` if the `p` relation variable is non-empty.| |`:showexpr s group ({sname,status,s#} as subrel)`| Display the result of grouping the `sname`, `status`, and `s#` into a subrel for each tuple in the `s` relation where the `city` attribute (not mentioned) is the grouping criteria| diff --git a/sql_optimizations_applied b/sql_optimizations_applied new file mode 100644 index 00000000..8ef6f30d --- /dev/null +++ b/sql_optimizations_applied @@ -0,0 +1,87 @@ +https://blog.jooq.org/2017/09/28/10-cool-sql-optimisations-that-do-not-depend-on-the-cost-model/#top3 + +1. Transitive Closure - done + +SELECT first_name, last_name, film_id +FROM actor a +JOIN film_actor fa ON a.actor_id = fa.actor_id +WHERE a.actor_id = 1; + +--> + +SELECT first_name, last_name, film_id +FROM actor a +JOIN film_actor fa ON a.actor_id = fa.actor_id +WHERE a.actor_id = 1 +AND fa.actor_id = 1; + +(x join y [on x.a = y.a]) where x.a = 1 +-> +(x where x.a = 1) join (y where y.a = 1) + +or + +x where a=@b and b=3 +-> +x where a=3 and b=3 + +2. Impossible Predicates - Done + +s where 3 = 5 +s where true -> s +s where false -> emptied s + +3. Join Elimination - Done + +SELECT first_name, last_name +FROM customer c +JOIN address a ON c.address_id = a.address_id + +--> + +SELECT first_name, last_name +FROM customer c + + +(x join y){x.attrs only} iff there is a foreign key constraint on the full join condition from x to y + +4. Silly Predicates - done + +where true -> X +where attr = attr -> X +insert s s where name = @name -> X + +5. Projections in Exists Subqueries + +Our exists clause is a projection against zero attributes already. + +6. Predicate Merging - Done + +where X and X -> where X +where X or X -> where X + +7. Empty Sets + +Use constraints to determine if a predicate is provably false: + +constraint x > 100 +where x = 10 -> where false + +X join false -> x where false +x join true -> x where false + +8. CHECK() constraints + +not relevant - see 7 + +9. Unneeded self join - done + +x join x -> x +(x where c1) join (x where c2) -> x where c1 and c2 +(x where c1) union (x where c2) -> x where c1 or c2 + +10. Predicate Pushdown - done + +(x where c1) where c2 -> x where c1 and c2 - done +x{proj} where c1 -> (x where c1){proj} #project on fewer tuples +(x union y) where c -> (x where c) union (y where c) \ No newline at end of file diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 207605ec..326af8b4 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -19,9 +19,19 @@ parseQuery :: Text -> Either ParserError Query parseQuery = parse (queryP <* semi <* eof) "" queryP :: Parser Query -queryP = (QuerySelect <$> selectP) <|> - (QueryValues <$> valuesP) <|> - (QueryTable <$> tableP) +queryP = E.makeExprParser queryTermP queryOpP + where + queryTermP = (QuerySelect <$> selectP) <|> + (QueryValues <$> valuesP) <|> + (QueryTable <$> tableP) + queryOpP = [[infixOpP "union" UnionQueryOperator, + infixOpP "intersect" IntersectQueryOperator, + infixOpP "except" ExceptQueryOperator + ]] + infixOpP nam op = + E.InfixL $ do + reserved nam + pure (\a b -> QueryOp op a b) valuesP :: Parser [[ScalarExpr]] valuesP = do diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs index 4268c22c..8f6c251c 100644 --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -1115,7 +1115,8 @@ convertSQLQuery sessionId (InProcessConnection conf) query = do Right (session, _schema) -> do -- TODO: enable SQL to leverage isomorphic schemas let ctx = Sess.concreteDatabaseContext session reEnv = RE.mkRelationalExprEnv ctx transGraph - typeF = optimizeAndEvalRelationalExpr reEnv + typeF expr = + RE.runRelationalExprM reEnv (RE.typeForRelationalExpr expr) -- convert SQL data into DataFrameExpr case evalConvertM mempty (convertQuery typeF query) of Left err -> pure (Left (SQLConversionError err)) diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs index c148aa0d..64c7438b 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -185,5 +185,6 @@ data SQLError = NotSupportedError T.Text | AggregateGroupByMismatchError ProjectionScalarExpr | GroupByColumnNotReferencedInGroupByError [ProjectionScalarExpr] | UnsupportedGroupByProjectionError ProjectionScalarExpr | + QueryOperatorTypeMismatchError QueryOperator Attributes Attributes | SQLRelationalError RelationalError deriving (Show, Eq, Generic, Typeable, NFData) diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 143d08e2..6fc0d971 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -55,6 +55,13 @@ type ConvertM = StateT TableContext (ExceptT SQLError Identity) runConvertM :: TableContext -> ConvertM a -> Either SQLError (a, TableContext) runConvertM tcontext m = runIdentity (runExceptT (runStateT m tcontext)) +runLocalConvertM :: ConvertM a -> ConvertM a +runLocalConvertM m = do + saveState <- get + ret <- m + put saveState + pure ret + evalConvertM :: TableContext -> ConvertM a -> Either SQLError a evalConvertM tcontext m = runIdentity (runExceptT (evalStateT m tcontext)) @@ -557,6 +564,23 @@ convertQuery typeF (QueryValues vals) = do convertQuery _typeF (QueryTable tname) = do rvName <- convertTableName tname pure $ baseDFExpr { convertExpr = RelationVariable rvName () } +convertQuery typeF (QueryOp op q1 q2) = do + let dfErr = NotSupportedError ("ORDER BY/LIMIT/OFFSET in " <> T.pack (show op)) + dfExpr1 <- runLocalConvertM (convertQuery typeF q1) + when (usesDataFrameFeatures dfExpr1) $ throwSQLE dfErr + dfType1 <- case typeF (convertExpr dfExpr1) of + Left err -> throwSQLE (SQLRelationalError err) + Right t -> pure t + + dfExpr2 <- runLocalConvertM (convertQuery typeF q2) + when (usesDataFrameFeatures dfExpr2) $ throwSQLE dfErr + dfType2 <- case typeF (convertExpr dfExpr2) of + Left err -> throwSQLE (SQLRelationalError err) + Right t -> pure t + + when (dfType1 /= dfType2) $ throwSQLE (QueryOperatorTypeMismatchError op (attributes dfType1) (attributes dfType2)) + + pure $ baseDFExpr { convertExpr = Union (convertExpr dfExpr1) (convertExpr dfExpr2) } convertSelect :: TypeForRelExprF -> Select -> ConvertM DataFrameExpr convertSelect typeF sel = do diff --git a/src/lib/ProjectM36/SQL/Select.hs b/src/lib/ProjectM36/SQL/Select.hs index 46a65ed8..679ade83 100644 --- a/src/lib/ProjectM36/SQL/Select.hs +++ b/src/lib/ProjectM36/SQL/Select.hs @@ -10,10 +10,15 @@ import Data.Hashable data Query = QuerySelect Select | QueryValues [[ScalarExpr]] | - QueryTable TableName + QueryTable TableName | + QueryOp QueryOperator Query Query deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant Query +data QueryOperator = UnionQueryOperator | IntersectQueryOperator | ExceptQueryOperator + deriving (Show, Eq, Generic, NFData) + deriving Serialise via WineryVariant QueryOperator + data Select = Select { distinctness :: Maybe Distinctness, projectionClause :: [SelectItem], tableExpr :: Maybe TableExpr, diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index 7d187b18..ecb9d0d9 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -46,13 +46,18 @@ type GraphRefSOptDatabaseContextExprM a = ReaderT GraphRefSOptDatabaseContextExp -- | A temporary function to be replaced by IO-based implementation. optimizeAndEvalRelationalExpr :: RelationalExprEnv -> RelationalExpr -> Either RelationalError Relation optimizeAndEvalRelationalExpr env expr = do - let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr) -- references parent tid instead of context! options- I could add the context to the graph with a new transid or implement an evalRelationalExpr in RE.hs to use the context (which is what I had previously) - graph = re_graph env + let graph = re_graph env ctx = re_context env gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph - optExpr <- runGraphRefSOptRelationalExprM (Just ctx) (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr) + optExpr <- optimizeRelationalExpr env expr runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr) +optimizeRelationalExpr :: RelationalExprEnv -> RelationalExpr -> Either RelationalError GraphRefRelationalExpr +optimizeRelationalExpr env expr = do + let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr) -- references parent tid instead of context! options- I could add the context to the graph with a new transid or implement an evalRelationalExpr in RE.hs to use the context (which is what I had previously) + ctx = re_context env + runGraphRefSOptRelationalExprM (Just ctx) (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr) + class Monad m => AskGraphContext m where askGraph :: m TransactionGraph askContext :: m DatabaseContext From 40935096e937c56af4c462d25ad91c0ab421aa82 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 7 May 2024 10:53:31 -0400 Subject: [PATCH 082/170] add tests for union, intersect, except SQL --- test/SQL/InterpreterTest.hs | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 9a178770..3d6369c3 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -174,7 +174,15 @@ testSelect = TestCase $ do "(relation{tuple{city \"London\", islondon True},tuple{city \"Paris\", islondon False},tuple{city \"Athens\", islondon False}})" ), -- union + ("SELECT * FROM s union select * from s", + "(s union s)", + "(s)" + ), -- intersect + ("select city from s intersect select 'New York' as city", + "((s{ city }) union ((relation{ }{ tuple{ } }:{city:=\"New York\"}){ city }))", + "(relation{tuple{city \"London\"},tuple{city \"New York\"}, tuple{city \"Athens\"}, tuple{city \"Paris\"}})" + ), -- except -- limit ("SELECT * FROM s LIMIT 10", @@ -251,24 +259,24 @@ testSelect = TestCase $ do check (sql, equivalent_tutd, confirmation_tutd) = do print sql --parse SQL - select <- case parse (selectP <* eof) "test" sql of + query <- case parse (queryP <* eof) "test" sql of Left err -> assertFailure (errorBundlePretty err) Right x -> do --print ("parsed SQL:"::String, x) pure x --parse tutd tutdAsDFExpr <- parseTutd equivalent_tutd - selectAsDFExpr <- case evalConvertM mempty (convertSelect typeF select) of + queryAsDFExpr <- case evalConvertM mempty (convertQuery typeF query) of Left err -> assertFailure (show err) Right x -> do --print ("convert SQL->tutd:"::String, x) pure x confirmationDFExpr <- parseTutd confirmation_tutd - --print ("selectAsRelExpr"::String, selectAsRelExpr) + --print ("selectAsRelExpr"::String, queryAsRelExpr) --print ("expected: "::String, pretty tutdAsDFExpr) - --print ("actual : "::String, pretty selectAsDFExpr) - assertEqual (T.unpack sql) tutdAsDFExpr selectAsDFExpr + --print ("actual : "::String, pretty queryAsDFExpr) + assertEqual (T.unpack sql) tutdAsDFExpr queryAsDFExpr --check that the expression can actually be executed eEvald <- executeDataFrameExpr sess conn tutdAsDFExpr sqlResult <- case eEvald of From ea0641885156d005cf5bf4a22dc936181b8840f9 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 7 May 2024 15:59:43 -0400 Subject: [PATCH 083/170] fix warnings --- examples/blog.hs | 1 - examples/hair.hs | 1 - examples/out_of_the_tarpit.hs | 1 - 3 files changed, 3 deletions(-) diff --git a/examples/blog.hs b/examples/blog.hs index ff24e180..5538ee93 100644 --- a/examples/blog.hs +++ b/examples/blog.hs @@ -7,7 +7,6 @@ import ProjectM36.Relation import ProjectM36.Tupleable import ProjectM36.Atom (relationForAtom) import ProjectM36.Tuple (atomForAttributeName) -import ProjectM36.DatabaseContext import Data.Either import GHC.Generics diff --git a/examples/hair.hs b/examples/hair.hs index 86ca038a..4879f20e 100644 --- a/examples/hair.hs +++ b/examples/hair.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings, DerivingVia #-} import ProjectM36.Client import ProjectM36.Relation.Show.Term -import ProjectM36.DatabaseContext import GHC.Generics import Data.Text import Control.DeepSeq diff --git a/examples/out_of_the_tarpit.hs b/examples/out_of_the_tarpit.hs index c36a09bc..308d2d6c 100644 --- a/examples/out_of_the_tarpit.hs +++ b/examples/out_of_the_tarpit.hs @@ -3,7 +3,6 @@ import ProjectM36.Client import ProjectM36.DataTypes.Primitive import ProjectM36.Tupleable -import ProjectM36.DatabaseContext import ProjectM36.Relation import ProjectM36.Error import Data.Either From 95d5f6605f63c58308d21a7d6eb0889d231ef580 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 7 May 2024 16:00:03 -0400 Subject: [PATCH 084/170] add missing QueryOperator JSON instances --- src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs index b3df3146..697636ac 100644 --- a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +++ b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs @@ -292,3 +292,6 @@ instance FromJSON NullsOrder instance ToJSON JoinOnCondition instance FromJSON JoinOnCondition + +instance ToJSON QueryOperator +instance FromJSON QueryOperator From 9c8d986b2532b0feefc56ae2ee9e3abb0ca6d130 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 7 May 2024 16:00:43 -0400 Subject: [PATCH 085/170] add more SQL aggregate functions min, sum, count --- src/bin/benchmark/Handles.hs | 1 - src/lib/ProjectM36/DataTypes/SQL/Null.hs | 38 +++++- src/lib/ProjectM36/SQL/Convert.hs | 165 ++--------------------- test/SQL/InterpreterTest.hs | 10 +- 4 files changed, 54 insertions(+), 160 deletions(-) diff --git a/src/bin/benchmark/Handles.hs b/src/bin/benchmark/Handles.hs index 4d3fc149..dfcf9f18 100644 --- a/src/bin/benchmark/Handles.hs +++ b/src/bin/benchmark/Handles.hs @@ -5,7 +5,6 @@ import ProjectM36.Persist import Options.Applicative import TutorialD.Interpreter import ProjectM36.Interpreter hiding (Parser) -import ProjectM36.DatabaseContext import TutorialD.Interpreter.Base hiding (option) import qualified Data.Text as T #if __GLASGOW_HASKELL__ < 804 diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index d1014675..b142b055 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -76,6 +76,21 @@ nullAtomFunctions = HS.fromList [ funcName = "sql_max", funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType), funcBody = FunctionBuiltInBody sqlMax + }, + Function { + funcName = "sql_min", + funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType), + funcBody = FunctionBuiltInBody sqlMin + }, + Function { + funcName = "sql_count", + funcType = foldAtomFuncType (TypeVariableType "a") IntegerAtomType, + funcBody = FunctionBuiltInBody sqlCount + }, + Function { + funcName = "sql_sum", + funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType), + funcBody = FunctionBuiltInBody sqlSum } ] <> sqlBooleanIntegerFunctions @@ -190,6 +205,12 @@ sqlIntegerUnaryFunction expectedAtomType op [x] _other -> Left AtomFunctionTypeMismatchError sqlIntegerUnaryFunction _ _ _ = Left AtomFunctionTypeMismatchError +sqlCount :: [Atom] -> Either AtomFunctionError Atom +sqlCount [RelationAtom relIn] = + case cardinality relIn of + Finite c -> pure $ IntegerAtom (toInteger c) + Countable -> Left AtomFunctionTypeMismatchError +sqlCount _ = Left AtomFunctionTypeMismatchError sqlAbs :: [Atom] -> Either AtomFunctionError Atom sqlAbs [IntegerAtom val] = pure $ IntegerAtom (abs val) @@ -201,9 +222,18 @@ sqlAbs [ConstructedAtom "SQLJust" aType [IntegerAtom val]] sqlAbs _other = Left AtomFunctionTypeMismatchError sqlMax :: [Atom] -> Either AtomFunctionError Atom -sqlMax [RelationAtom relIn] = +sqlMax = sqlIntegerAgg max + +sqlMin :: [Atom] -> Either AtomFunctionError Atom +sqlMin = sqlIntegerAgg min + +sqlSum :: [Atom] -> Either AtomFunctionError Atom +sqlSum = sqlIntegerAgg (+) + +sqlIntegerAgg :: (Integer -> Integer -> Integer) -> [Atom] -> Either AtomFunctionError Atom +sqlIntegerAgg op [RelationAtom relIn] = case oneTuple relIn of - Nothing -> pure $ nullAtom IntegerAtomType Nothing -- SQL max of empty table is NULL + Nothing -> pure $ nullAtom IntegerAtomType Nothing -- SQL max/min of empty table is NULL Just oneTup -> if atomTypeForAtom (newVal oneTup) /= IntegerAtomType then Left AtomFunctionTypeMismatchError @@ -214,12 +244,12 @@ sqlMax [RelationAtom relIn] = nullMax acc nextVal = let mNextVal = sqlNullableIntegerToMaybe nextVal mOldVal = sqlNullableIntegerToMaybe acc - mResult = max <$> mNextVal <*> mOldVal + mResult = op <$> mNextVal <*> mOldVal in nullAtom IntegerAtomType (case mResult of Nothing -> Nothing Just v -> Just (IntegerAtom v)) -sqlMax _ = Left AtomFunctionTypeMismatchError +sqlIntegerAgg _ _ = Left AtomFunctionTypeMismatchError sqlNullableIntegerToMaybe :: Atom -> Maybe Integer diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 6fc0d971..780f9af7 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -122,12 +122,13 @@ prettyColumnAliasRemapper :: ColumnAliasRemapper -> String prettyColumnAliasRemapper cAMap = intercalate ", " $ map (\(realAttr, (attrAlias, colNameSet)) -> "real->" <> T.unpack realAttr <> ":alias->" <> T.unpack attrAlias <> ":alts->{" <> show colNameSet <> "}") (M.toList cAMap) - +{- traceStateM :: ConvertM () traceStateM = do s <- get traceM (prettyTableContext s) - +-} + -- key: alias value: real column attribute name type ColumnAliasMap = M.Map ColumnAlias AttributeName @@ -175,10 +176,6 @@ withSubSelect m = do diff <- foldM tableDiffFolder mempty (M.toList postSub) -{- let diff = M.differenceWith tctxDiff postSub orig - tctxDiff (rexprA, attrsA, colAliasMapA) (_, _, colAliasMapB) = - Just (rexprA, attrsA, M.difference colAliasMapB colAliasMapA)-} --- traceShowM ("subselect diff"::String, diff) pure (ret, diff) -- if we find a column naming conflict, generate a non-conflicting name for insertion into the column alias map @@ -217,22 +214,6 @@ noteColumnMention mTblAlias colName mColAlias = do -- traceShowM ("noteColumnMention"::String, mTblAlias, colName) -- traceStateM tc@(TableContext tcontext) <- get -{- tblAlias' <- case mTblAlias of - Just tblAlias -> do - void $ lookupTable tblAlias - pure tblAlias - Nothing ->do - -- scan column names for match- if there are multiple matches, return a column ambiguity error - ret <- findOneColumn colName --- traceShowM ("insertColumn2", colName) - pure ret-} - -- insert into the column alias map -{- let colAttr = case colName of - ColumnName [c] -> c - ColumnName [t,c] -> - origAttrName = case colName of - ColumnName [c] -> c - ColumnName [_,c] -> c-} -- check if we already have a mention mapping let lookupWithTableAlias (TableAlias tAlias) colAttr = do when (isJust mTblAlias && Just (TableAlias tAlias) /= mTblAlias) (throwSQLE (TableAliasMismatchError (TableAlias tAlias))) @@ -298,75 +279,6 @@ noteColumnMention mTblAlias colName mColAlias = do throwSQLE (AmbiguousColumnResolutionError colName) other@ColumnName{} -> throwSQLE (UnexpectedColumnNameError other) - ------- -{- case findNotedColumn' colName tc of - Right [] -> do - -- no match found, so we can insert this as a new column alias - let colAlias = case mColAlias of - Just al -> al - Nothing -> --ColumnAlias (unTableAlias tblAlias' <> "." <> origAttrName) - ColumnAlias origAttrName - insertColumnAlias tblAlias' origAttrName colAlias colName - pure colAlias - Right [match] -> - -- one match found- error - throwSQLE (AmbiguousColumnResolutionError colName) - Right (match:_) -> - -- multiple matches found- error - throwSQLE (AmbiguousColumnResolutionError colName) - Left (ColumnResolutionError{}) -> - throwSQLE err-} -{- case M.lookup tblAlias' tcontext of - Nothing -> throwSQLE (MissingTableReferenceError tblAlias') - Just (_,_,colAliasRemapper) -> do - case attributeNameForAttributeAlias colAttr colAliasRemapper of - Right _ -> pure (ColumnAlias colAttr) - Left _ -> do -- no match previously recorded, so add it-} -{- when (newAlias `elem` allColumnAliases tcontext) $ do - traceShowM ("gonk error", - "colName", colName, - "mTblAlias", mTblAlias, - "mColAlias", mColAlias, -p tmap) - throwSQLE (DuplicateColumnAliasError newAlias)-} --duplicate column aliases are OK - --verify that the alias is not duplicated -{- let colAlias = case mColAlias of - Just al -> al - Nothing -> --ColumnAlias (unTableAlias tblAlias' <> "." <> origAttrName) - ColumnAlias origAttrName - insertColumnAlias tblAlias' origAttrName colAlias colName - pure colAlias --} -{- --- | Add a column alias for a column which has already been inserted into the TableContext. -addColumnAlias' :: TableContext -> TableAlias -> ColumnAlias -> AttributeName -> Either SQLError TableContext -addColumnAlias' (TableContext tctx) tAlias colAlias@(ColumnAlias colText) attr = do - case M.lookup tAlias tctx of - Nothing -> Left (ColumnAliasResolutionError colAlias) - Just (rvexpr, attrs, colMap) -> - --check that the attribute is present in attributes, then plop it into the colMap and return the updated TableContext - if attr `A.isAttributeNameContained` attrs then do - insertColumnAlias - let newColMap = M.insert colAlias attr colMap - newTContext = M.insert tAlias (rvexpr, attrs, newColMap) tctx - pure (TableContext newTContext) - else do - traceShow "addColAlias'" $ Left (ColumnResolutionError (ColumnName [attr])) - -addColumnAlias :: TableAlias -> ColumnAlias -> AttributeName -> ConvertM () -addColumnAlias tAlias colAlias attrName = do - tctx <- get - case addColumnAlias' tctx tAlias colAlias attrName of - Left err -> throwSQLE err - Right tctx' -> put tctx' - -allColumnAliases :: TableContext -> [ColumnAlias] -allColumnAliases (TableContext tmap) = - foldl' folder [] tmap - where - folder acc (_,_,colmap) = M.keys colmap <> acc --} lookupTable :: TableAlias -> ConvertM (RelationalExpr, Attributes, ColumnAliasRemapper) lookupTable ta = do (TableContext map') <- get @@ -374,17 +286,6 @@ lookupTable ta = do Nothing -> throwSQLE (MissingTableReferenceError ta) Just res -> pure res -{- --- | Merge table contexts (used in subselects) -mergeContext :: TableContext -> ConvertM ColumnAliasMap -mergeContext (TableContext ctxB) = do - (TableContext tMapA) <- get - foldM folder mempty (M.toList tMapA) - where - folder acc (tAlias, (re,attrs, _)) = do - colMap <- insertTable tAlias re attrs - pure (M.union acc colMap) --} -- | Find a column name or column alias in the underlying table context. Returns key into table context. findColumn :: ColumnName -> ConvertM [TableAlias] findColumn targetCol = do @@ -493,18 +394,7 @@ attributeNameForColumnName colName = do ColumnName [_, col] | col `A.isAttributeNameContained` rvattrs -> -- the column has not been aliased, so we presume it can be use the column name directly pure col - _ -> throwSQLE $ traceShow ("attrnameforcolname"::String, rvattrs, colName) $ ColumnResolutionError colName -{- -attributeNameForColumnName :: ColumnName -> ConvertM AttributeName -attributeNameForColumnName colName = do - s <- get - case attributeNameForColumnName' colName s of - Left err -> throwSQLE err - Right al -> do - traceStateM - traceShowM ("attributeNameForColumnName"::String, colName, "->"::String, al) - pure al - -} + _ -> throwSQLE $ ColumnResolutionError colName wrapTypeF :: TypeForRelExprF -> RelationalExpr -> ConvertM Relation wrapTypeF typeF relExpr = @@ -512,32 +402,6 @@ wrapTypeF typeF relExpr = Left relError -> throwSQLE (SQLRelationalError relError) Right v -> pure v - --- | Return the table alias for the column name iff the attribute is unique. Used for attribute resolution. -{- -tableAliasForColumnName :: TypeForRelExprF -> ColumnName -> TableContext -> Either SQLError TableAlias --- the table alias is included -tableAliasForColumnName typeF cn@(ColumnName [tAlias, _]) (TableContext tMap) = do - if M.member (TableAlias tAlias) tMap then - pure (TableAlias tAlias) - else - Left (ColumnResolutionError cn) -tableAliasForColumnName typeF qn@(ColumnName [colName]) (TableContext tMap) = do - --look up the column name in all possible tables - res <- foldM folder Nothing (M.toList tMap) - case res of - Just res -> pure res - Nothing -> Left (ColumnResolutionError qn) - where - folder :: Maybe ColumnName -> (TableAlias, RelationalExpr) -> _ - folder Just{} _ = Left (AmbiguousColumnResolutionError qn) - folder Nothing (TableAlias tableAlias, (rvExpr,_)) = do - tRel <- wrapTypeF typeF rvExpr -- we could cache this in the table alias map ADT - --traceShowM ("findColName", rvExpr, tRel) - if colName `S.member` attributeNameSet (attributes tRel) then - pure (Just (ColumnName [tableAlias, colName])) - else pure Nothing --} baseDFExpr :: DataFrameExpr baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () [TupleExpr mempty]), --relationTrue if the table expression is empty "SELECT 1" orderExprs = [], @@ -695,12 +559,6 @@ convertSelectItem typeF acc (c,selItem) = colinfo (ColumnProjectionName [ProjectionName name]) = do findOneColumn (ColumnName [name]) colinfo colProjName = throwSQLE $ UnexpectedColumnProjectionName colProjName -{- processGroupBy e@(sexpr, alias) = (replaceProjScalarExpr groupByReplacer sexpr, alias) - groupByReplacer expr = - case expr of - FunctionApplication "sql_max" [targetColumn] -> FunctionApplication "sql_max" [ - _ -> expr-} - convertProjection :: TypeForRelExprF -> [SelectItem] -> [GroupByExpr] -> Maybe HavingExpr -> ConvertM (RelationalExpr -> RelationalExpr) convertProjection typeF selItems groupBys havingExpr = do @@ -752,6 +610,7 @@ convertProjection typeF selItems groupBys havingExpr = do -- let fAggregates -- apply rename renamesSet <- foldM (\acc (qProjName, (ColumnAlias newName)) -> do + traceShowM ("renamesSet"::String, qProjName, newName) oldName <- convertColumnProjectionName qProjName pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) let fRenames = if S.null renamesSet then id else Rename renamesSet @@ -1126,6 +985,8 @@ lookupFunc qname = other -> throwSQLE $ NotSupportedError ("function name: " <> T.pack (show other)) where f n args = FunctionAtomExpr n args () + aggMapper (FuncName [nam], nam') = (nam, f nam') + aggMapper (FuncName other,_) = error ("unexpected multi-component SQL aggregate function: " <> show other) sqlFuncs = [(">",f "sql_gt"), ("<",f "sql_lt"), (">=",f "sql_gte"), @@ -1136,9 +997,8 @@ lookupFunc qname = ("+", f "sql_add"), ("and", f "sql_and"), ("or", f "sql_or"), - ("abs", f "sql_abs"), - ("max", f "sql_max") - ] + ("abs", f "sql_abs") + ] <> map aggMapper aggregateFunctions -- | Used in join condition detection necessary for renames to enable natural joins. @@ -1307,7 +1167,7 @@ convertInsert typeF ins = do else Rename (S.fromList (filter rendundantRename (zip rvExprAttrNames insAttrNames))) (convertExpr dfExpr) rendundantRename (a,b) = a /= b - traceShowM ("ins"::String, insExpr) + --traceShowM ("ins"::String, insExpr) pure $ B.Insert rvTarget insExpr convertDelete :: TypeForRelExprF -> Delete.Delete -> ConvertM DatabaseContextExpr @@ -1399,7 +1259,9 @@ convertGroupBy _typeF groupBys mHavingExpr sqlProjection = do AggGroupByItem pe _gb -> pure $ info { aggregates = pe : aggregates info } NonAggGroupByItem (Identifier colName) gb -> do + traceShowM ("convertGroupBy"::String, colName) aname <- convertColumnProjectionName colName + traceShowM ("convertGroupBy2"::String, "done") pure $ info { nonAggregates = (aname, gb) : nonAggregates info } NonAggGroupByItem pe _ -> do throwSQLE (UnsupportedGroupByProjectionError pe) @@ -1445,7 +1307,8 @@ emptyGroupByInfo = GroupByInfo { aggregates = [], nonAggregates = [], havingRest aggregateFunctions :: [(FuncName, FunctionName)] aggregateFunctions = [(FuncName ["max"], "sql_max"), (FuncName ["min"], "sql_min"), - (FuncName ["sum"], "sql_sum")] + (FuncName ["sum"], "sql_sum"), + (FuncName ["count"], "sql_count")] isAggregateFunction :: FuncName -> Bool isAggregateFunction fname = fname `elem` map fst aggregateFunctions diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 3d6369c3..91dbcef1 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -151,20 +151,20 @@ testSelect = TestCase $ do "(relation{tuple{attr_1 SQLJust 4}})" ), -- where not exists - -- group by + -- group by with max aggregate ("SELECT city,max(status) FROM s GROUP BY city", "((s group ({all but city} as `_sql_aggregate`) : {attr_2:=sql_max(@`_sql_aggregate`{status})}){city,attr_2})", "(relation{city Text, attr_2 SQLNullable Integer}{tuple{city \"London\", attr_2 SQLJust 20}, tuple{city \"Paris\", attr_2 SQLJust 30}, tuple{city \"Athens\", attr_2 SQLJust 30}})" ), - -- group by with aggregate column alias + -- group by with aggregate max column alias ("SELECT city,max(status) as status FROM s GROUP BY city", "((s group ({all but city} as `_sql_aggregate`) : {status:=sql_max(@`_sql_aggregate`{status})}){city,status})", "(relation{city Text, status SQLNullable Integer}{tuple{city \"London\", status SQLJust 20}, tuple{city \"Paris\", status SQLJust 30}, tuple{city \"Athens\", status SQLJust 30}})"), - -- aggregate without grouping + -- aggregate max without grouping ("SELECT max(status) as status FROM s", "(((s group ({all but } as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } )}){ status })", "(relation{status SQLNullable Integer}{tuple{status SQLJust 30}})"), - -- group by having + -- group by having max ("select city,max(status) as status from s group by city having max(status)=30", "((((s group ({all but city} as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } ), `_sql_having`:=sql_coalesce_bool( sql_equals( sql_max( (@`_sql_aggregate`){ status } ), 30 ) )}){ city, status }) where `_sql_having`=True)", "(relation{city Text,status SQLNullable Integer}{tuple{city \"Athens\",status SQLJust 30},tuple{city \"Paris\",status SQLJust 30}})"), @@ -184,6 +184,8 @@ testSelect = TestCase $ do "(relation{tuple{city \"London\"},tuple{city \"New York\"}, tuple{city \"Athens\"}, tuple{city \"Paris\"}})" ), -- except + ("select city from s except select 'London' as city", + ), -- limit ("SELECT * FROM s LIMIT 10", "(s) limit 10", From 41dfaef65a0c34ac711e58c770a096ca8cfd5ea2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 8 May 2024 01:08:49 -0400 Subject: [PATCH 086/170] fix SQL tests --- src/lib/ProjectM36/SQL/Convert.hs | 18 ++++++++++++------ test/SQL/InterpreterTest.hs | 8 +++++--- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 780f9af7..e5abb062 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -444,7 +444,12 @@ convertQuery typeF (QueryOp op q1 q2) = do when (dfType1 /= dfType2) $ throwSQLE (QueryOperatorTypeMismatchError op (attributes dfType1) (attributes dfType2)) - pure $ baseDFExpr { convertExpr = Union (convertExpr dfExpr1) (convertExpr dfExpr2) } + let relOp = case op of + UnionQueryOperator -> Union + ExceptQueryOperator -> Difference + IntersectQueryOperator -> Join + + pure $ baseDFExpr { convertExpr = relOp (convertExpr dfExpr1) (convertExpr dfExpr2) } convertSelect :: TypeForRelExprF -> Select -> ConvertM DataFrameExpr convertSelect typeF sel = do @@ -610,7 +615,6 @@ convertProjection typeF selItems groupBys havingExpr = do -- let fAggregates -- apply rename renamesSet <- foldM (\acc (qProjName, (ColumnAlias newName)) -> do - traceShowM ("renamesSet"::String, qProjName, newName) oldName <- convertColumnProjectionName qProjName pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) let fRenames = if S.null renamesSet then id else Rename renamesSet @@ -753,7 +757,7 @@ convertProjectionScalarExpr typeF expr = do naked (BoolAtom False) --pure $ ConstructedAtomExpr "False" [] () NullLiteral -> pure $ ConstructedAtomExpr "SQLNull" [] () - Identifier i -> + Identifier i -> do AttributeAtomExpr <$> convertColumnProjectionName i BinaryOperator exprA op exprB -> do a <- convertProjectionScalarExpr typeF exprA @@ -762,7 +766,11 @@ convertProjectionScalarExpr typeF expr = do pure $ f [a,b] FunctionApplication fname fargs -> do func <- lookupFunc fname - fargs' <- mapM (convertProjectionScalarExpr typeF) fargs + -- as a special case, count(*) is valid, if non-sensical SQL, so handle it here + fargs' <- if fname == FuncName ["count"] && fargs == [Identifier (ColumnProjectionName [Asterisk])] then + pure [AttributeAtomExpr "_sql_aggregate"] + else + mapM (convertProjectionScalarExpr typeF) fargs pure (func fargs') PrefixOperator op sexpr -> do func <- lookupOperator True op @@ -1259,9 +1267,7 @@ convertGroupBy _typeF groupBys mHavingExpr sqlProjection = do AggGroupByItem pe _gb -> pure $ info { aggregates = pe : aggregates info } NonAggGroupByItem (Identifier colName) gb -> do - traceShowM ("convertGroupBy"::String, colName) aname <- convertColumnProjectionName colName - traceShowM ("convertGroupBy2"::String, "done") pure $ info { nonAggregates = (aname, gb) : nonAggregates info } NonAggGroupByItem pe _ -> do throwSQLE (UnsupportedGroupByProjectionError pe) diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 91dbcef1..05e9bda1 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -179,12 +179,14 @@ testSelect = TestCase $ do "(s)" ), -- intersect - ("select city from s intersect select 'New York' as city", - "((s{ city }) union ((relation{ }{ tuple{ } }:{city:=\"New York\"}){ city }))", - "(relation{tuple{city \"London\"},tuple{city \"New York\"}, tuple{city \"Athens\"}, tuple{city \"Paris\"}})" + ("select city from s intersect select 'London' as city", + "((s{ city }) join ((relation{ }{ tuple{ } }:{city:=\"London\"}){ city }))", + "(relation{tuple{city \"London\"}})" ), -- except ("select city from s except select 'London' as city", + "((s{city}) minus ((relation{}{tuple{}}:{city:=\"London\"}){city}))", + "(relation{tuple{city \"Athens\"}, tuple{city \"Paris\"}})" ), -- limit ("SELECT * FROM s LIMIT 10", From 7f5ad44118b2fe1210eaa54c1e9be26ffdcc359c Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 9 May 2024 01:18:36 -0400 Subject: [PATCH 087/170] add "is not null" --- src/bin/SQL/Interpreter/Select.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 326af8b4..1b4d2c1b 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -166,7 +166,7 @@ scalarExprOp = --binarySymbolsN ["not", "like"] ], map binarySymbolN ["<",">",">=","<=","!=","<>","="], - [postfixKeywords ["is","null"]], + [postfixKeywords ["is","null"], postfixKeywords ["is","not","null"]], {- [binarySymbolsN ["is", "distinct", "from"], binarySymbolsN ["is", "not", "distinct", "from"]],-} [binarySymbolL "and"], From bed20c6765dc8568378ef3d5cc2b5241b35a4fd0 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 9 May 2024 01:27:08 -0400 Subject: [PATCH 088/170] fix count(*) vs count(city) fix is null function --- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 17 +++++++++-------- src/lib/ProjectM36/SQL/Convert.hs | 19 ++++++++++++++++--- test/SQL/InterpreterTest.hs | 15 +++++++++++++++ 3 files changed, 40 insertions(+), 11 deletions(-) diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index b142b055..a8b56fd1 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -22,14 +22,6 @@ nullTypeConstructorMapping = [(ADTypeConstructorDef "SQLNullable" ["a"], nullAtomFunctions :: AtomFunctions nullAtomFunctions = HS.fromList [ - Function { - funcName = "sql_isnull", --this function works on any type variable, not just SQLNullable because removing the isnull function in cases where the type is clearly not SQLNullable is more difficult - funcType = [TypeVariableType "a", BoolAtomType], - funcBody = FunctionBuiltInBody $ - \case - a:[] -> pure $ BoolAtom (isNull a) - _ -> error "isnull" -- $ Left AtomFunctionTypeMismatchError - }, Function { funcName = "sql_equals", funcType = [TypeVariableType "a", @@ -91,6 +83,11 @@ nullAtomFunctions = HS.fromList [ funcName = "sql_sum", funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType), funcBody = FunctionBuiltInBody sqlSum + }, + Function { + funcName = "sql_isnull", + funcType = [TypeVariableType "a", BoolAtomType], + funcBody = FunctionBuiltInBody sqlIsNull } ] <> sqlBooleanIntegerFunctions @@ -278,3 +275,7 @@ sqlEquals [a,b] | sqlEqualsTypes a b = maybeNullAtom other = Just other sqlEquals _other = Left AtomFunctionTypeMismatchError +sqlIsNull :: AtomFunctionBodyType +sqlIsNull [ConstructedAtom "SQLNull" (ConstructedAtomType "SQLNullable" _) []] = pure (BoolAtom True) +sqlIsNull [_arg] = pure (BoolAtom False) +sqlIsNull _other = Left AtomFunctionTypeMismatchError diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index e5abb062..0e8f6c34 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -690,9 +690,12 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do PostfixOperator expr (OperatorName ops) -> do expr' <- convertScalarExpr typeF expr -- traceShowM ("convertWhereClause"::String, expr') + let isnull = AtomExprPredicate (coalesceBoolF (FunctionAtomExpr "sql_isnull" [expr'] ())) case ops of - ["is", "null"] -> do - pure $ AtomExprPredicate (coalesceBoolF (FunctionAtomExpr "sql_isnull" [expr'] ())) + ["is", "null"] -> + pure isnull + ["is", "not", "null"] -> + pure (NotPredicate isnull) other -> throwSQLE $ NotSupportedError ("postfix operator: " <> T.pack (show other)) InExpr inOrNotIn sexpr (InList matches') -> do eqExpr <- convertScalarExpr typeF sexpr @@ -1423,11 +1426,19 @@ convertGroupByInfo ginfo task = -- find SQL aggregate functions and replace then with folds on attribute "_sql_aggregate" processSQLAggregateFunctions :: AtomExpr -> AtomExpr -processSQLAggregateFunctions expr = +processSQLAggregateFunctions expr = case expr of AttributeAtomExpr{} -> expr NakedAtomExpr{} -> expr FunctionAtomExpr fname [AttributeAtomExpr attrName] () + | fname == "sql_count" && -- count(*) counts the number of rows + attrName == "_sql_aggregate" -> expr + | fname == "sql_count" -> -- count(city) counts the number city elements that are not null + callF fname [RelationAtomExpr + (Restrict + (NotPredicate + (AtomExprPredicate + (callF "sql_isnull" [AttributeAtomExpr attrName]))) (RelationValuedAttribute "_sql_aggregate"))] | fname `elem` map snd aggregateFunctions -> FunctionAtomExpr fname [RelationAtomExpr (Project (AttributeNames (S.singleton attrName)) (RelationValuedAttribute "_sql_aggregate"))] () @@ -1435,3 +1446,5 @@ processSQLAggregateFunctions expr = RelationAtomExpr{} -> expr --not supported in SQL IfThenAtomExpr ifE thenE elseE -> IfThenAtomExpr (processSQLAggregateFunctions ifE) (processSQLAggregateFunctions thenE) (processSQLAggregateFunctions elseE) ConstructedAtomExpr{} -> expr --not supported in SQL + where + callF fname args = FunctionAtomExpr fname args () diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 05e9bda1..5ee95509 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -168,6 +168,16 @@ testSelect = TestCase $ do ("select city,max(status) as status from s group by city having max(status)=30", "((((s group ({all but city} as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } ), `_sql_having`:=sql_coalesce_bool( sql_equals( sql_max( (@`_sql_aggregate`){ status } ), 30 ) )}){ city, status }) where `_sql_having`=True)", "(relation{city Text,status SQLNullable Integer}{tuple{city \"Athens\",status SQLJust 30},tuple{city \"Paris\",status SQLJust 30}})"), + -- count(*) aggregate + ("select count(*) as c from s", + "(((s group ({all but } as `_sql_aggregate`)):{c:=sql_count( @`_sql_aggregate` )}){ c })", + "(relation{tuple{c 5}})" + ), + -- count(city) aggregate counts how many cities are not null + ("select count(city) as c from s", + "(((s group ({all but } as `_sql_aggregate`)):{c:=sql_count( ((@`_sql_aggregate`) where not( sql_isnull( @city ) )) )}){ c })", + "(relation{tuple{c 5}})" + ), -- case when ("SELECT city,case when city='London' then true else false end as islondon from s", "((s:{islondon:=if sql_coalesce_bool( sql_equals( @city, \"London\" ) ) then True else False}){ city, islondon })", @@ -241,6 +251,11 @@ testSelect = TestCase $ do ("SELECT * FROM snull WHERE city IS NULL", "(snull where sql_coalesce_bool(sql_isnull(@city)))", "(snull where s#=\"S2\")"), + -- restriction IS NOT NULL + ("SELECT city FROM s WHERE city IS NOT NULL", + "(((s where not sql_coalesce_bool(sql_isnull(@city)))){city})", + "(s{city})" + ), ("SELECT NULL AND FALSE", "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNull,False)}){attr_1})", "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust False}})"), From 030e0d59591b33fc86315aa99f5b234d017be89d Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 9 May 2024 18:13:28 -0400 Subject: [PATCH 089/170] update ReferencedTransactionIds for this branch --- src/lib/ProjectM36/ReferencedTransactionIds.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/lib/ProjectM36/ReferencedTransactionIds.hs b/src/lib/ProjectM36/ReferencedTransactionIds.hs index 581f662b..96eef90f 100644 --- a/src/lib/ProjectM36/ReferencedTransactionIds.hs +++ b/src/lib/ProjectM36/ReferencedTransactionIds.hs @@ -23,10 +23,11 @@ instance ReferencedTransactionIds a => ReferencedTransactionIds (RelationalExprB MakeStaticRelation{} -> S.empty ExistingRelation{} -> S.empty RelationVariable _ marker -> referencedTransactionIds marker + RelationValuedAttribute _ -> S.empty Project attrNames expr -> S.union (referencedTransactionIds attrNames) (referencedTransactionIds expr) Union exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) Join exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) - Rename _ _ expr -> referencedTransactionIds expr + Rename _ expr -> referencedTransactionIds expr Difference exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB) Group attrNames _ expr -> S.union (referencedTransactionIds attrNames) (referencedTransactionIds expr) Ungroup _ expr -> referencedTransactionIds expr @@ -101,6 +102,10 @@ instance ReferencedTransactionIds a => ReferencedTransactionIds (AtomExprBase a) referencedTransactionIds rExpr ConstructedAtomExpr _ args marker -> S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args)) + IfThenAtomExpr ifE thenE elseE -> + S.unions [referencedTransactionIds ifE, + referencedTransactionIds thenE, + referencedTransactionIds elseE] -- only the relvars can reference other transactions instance ReferencedTransactionIds DatabaseContext where From 57a97b6b93c4d4e6d93794aadf49cea424c80911 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 13 May 2024 00:42:51 -0400 Subject: [PATCH 090/170] working create table tests --- project-m36.cabal | 5 +- src/bin/SQL/Interpreter/Base.hs | 4 +- src/bin/SQL/Interpreter/CreateTable.hs | 25 ++++- src/bin/SQL/Interpreter/Select.hs | 2 +- .../Interpreter/DatabaseContextExpr.hs | 3 +- src/bin/TutorialD/Printer.hs | 28 ++++-- src/lib/ProjectM36/DatabaseContext.hs | 6 ++ src/lib/ProjectM36/InclusionDependency.hs | 13 ++- src/lib/ProjectM36/Key.hs | 5 +- src/lib/ProjectM36/SQL/Convert.hs | 99 ++++++++++++++----- src/lib/ProjectM36/SQL/CreateTable.hs | 8 +- test/SQL/InterpreterTest.hs | 71 ++++++++++++- 12 files changed, 217 insertions(+), 52 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index 15a7ad37..dc7edf72 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -299,7 +299,8 @@ Executable sqlegacy SQL.Interpreter.DBUpdate, SQL.Interpreter.CreateTable, SQL.Interpreter.DropTable, - TutorialD.Printer + TutorialD.Printer, + TutorialD.Interpreter.Base Main-Is: ./SQL/Interpreter/sqlegacy.hs if os(windows) @@ -401,7 +402,7 @@ Test-Suite test-sql import: commontest type: exitcode-stdio-1.0 main-is: SQL/InterpreterTest.hs - Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator, ProjectM36.Interpreter + Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator, ProjectM36.Interpreter, SQL.Interpreter.CreateTable TutorialD.Printer Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific, recursion-schemes diff --git a/src/bin/SQL/Interpreter/Base.hs b/src/bin/SQL/Interpreter/Base.hs index f0883527..b851c94b 100644 --- a/src/bin/SQL/Interpreter/Base.hs +++ b/src/bin/SQL/Interpreter/Base.hs @@ -42,7 +42,7 @@ braces = between (symbol "{") (symbol "}") identifier :: Parser Text identifier = do istart <- letterChar <|> char '_' - toLower <$> identifierRemainder istart + (toLower <$> identifierRemainder istart) <* spaceConsumer identifierRemainder :: Char -> Parser Text identifierRemainder c = do @@ -83,7 +83,7 @@ double = Lex.float <* spaceConsumer -- | When an identifier is quoted, it can contain any string. quotedIdentifier :: Parser Text quotedIdentifier = - T.pack <$> (doubleQuote *> many (escapedDoubleQuote <|> notDoubleQuote) <* doubleQuote) + (T.pack <$> (doubleQuote *> many (escapedDoubleQuote <|> notDoubleQuote) <* doubleQuote)) <* spaceConsumer where doubleQuote = char '"' escapedDoubleQuote = chunk "\"\"" *> pure '"' diff --git a/src/bin/SQL/Interpreter/CreateTable.hs b/src/bin/SQL/Interpreter/CreateTable.hs index 7d515a78..c2f9722a 100644 --- a/src/bin/SQL/Interpreter/CreateTable.hs +++ b/src/bin/SQL/Interpreter/CreateTable.hs @@ -5,6 +5,7 @@ import ProjectM36.SQL.CreateTable import SQL.Interpreter.Base import ProjectM36.Interpreter import Text.Megaparsec +import Control.Monad.Permutations createTableP :: Parser CreateTable createTableP = do @@ -33,7 +34,27 @@ columnTypeP = choice (map (\(nam, typ) -> reserved nam *> pure typ) types) ("double", DoubleColumnType), ("datetime", DateTimeColumnType)] +data PerColumnConstraintsParse = + PerColumnConstraintsParse { parse_notNullConstraint :: Bool, + parse_uniquenessConstraint :: Bool, + parse_primaryKeyConstraint :: Bool, + parse_references :: Maybe (TableName, UnqualifiedColumnName) + } + +referencesP :: Parser (TableName, UnqualifiedColumnName) +referencesP = do + reserved "references" + (,) <$> tableNameP <*> parens unqualifiedColumnNameP + perColConstraintsP :: Parser PerColumnConstraints perColConstraintsP = do - let baseConstraints = PerColumnConstraints { notNullConstraint = False } - (try (reserveds "not null" *> pure (baseConstraints { notNullConstraint = True}))) <|> pure baseConstraints + parsed <- runPermutation $ + PerColumnConstraintsParse <$> + toPermutationWithDefault False (try (reserveds "not null" *> pure True)) <*> + toPermutationWithDefault False (reserved "unique" *> pure True) <*> + toPermutationWithDefault False (reserved "primary key" *> pure True) <*> + toPermutationWithDefault Nothing (Just <$> referencesP) + pure (PerColumnConstraints { notNullConstraint = (parse_notNullConstraint parsed) || (parse_primaryKeyConstraint parsed), + uniquenessConstraint = (parse_uniquenessConstraint parsed) || (parse_primaryKeyConstraint parsed), + references = parse_references parsed }) + diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 1b4d2c1b..c457ecb0 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -131,7 +131,7 @@ orderByP = (reserveds "nulls last" $> NullsLast) nameP :: Parser Text -nameP = quotedIdentifier <|> identifier +nameP = (quotedIdentifier <|> identifier) <* spaceConsumer qualifiedNameP' :: Parser [Text] qualifiedNameP' = sepBy1 nameP (symbol ".") diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs index 61dbca89..16dd464f 100644 --- a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs @@ -2,6 +2,7 @@ module TutorialD.Interpreter.DatabaseContextExpr where import ProjectM36.Base import ProjectM36.Interpreter +import ProjectM36.DatabaseContext import TutorialD.Interpreter.Base import qualified Data.Text as T import TutorialD.Interpreter.RelationalExpr @@ -58,7 +59,7 @@ multilineSep = newline >> pure "\n" multipleDatabaseContextExprP :: Parser DatabaseContextExpr multipleDatabaseContextExprP = do exprs <- filter (/= NoOperation) <$> sepBy1 databaseContextExprP semi - pure (MultipleExpr exprs) + pure (someDatabaseContextExprs exprs) insertP :: Parser DatabaseContextExpr insertP = do diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index f2243617..bd0fed17 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -18,6 +18,9 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.Text.Encoding as TE import Data.UUID hiding (null) import Data.Text (Text) +import TutorialD.Interpreter.Base (uncapitalizedIdentifier) +import Text.Megaparsec +import Data.Either (isLeft) renderPretty :: Pretty a => a -> Text renderPretty = renderStrict . layoutPretty defaultLayoutOptions . pretty @@ -40,7 +43,7 @@ instance Pretty Atom where pretty (ConstructedAtom n _ as) = pretty n <+> prettyList as instance Pretty AtomExpr where - pretty (AttributeAtomExpr attrName) = pretty ("@" <> attrName) + pretty (AttributeAtomExpr attrName) = prettyAttributeName ("@" <> attrName) pretty (NakedAtomExpr atom) = pretty atom pretty (FunctionAtomExpr atomFuncName' atomExprs _) = pretty atomFuncName' <> prettyAtomExprsAsArguments atomExprs pretty (RelationAtomExpr relExpr) = pretty relExpr @@ -51,7 +54,7 @@ instance Pretty AtomExpr where prettyAtomExpr :: AtomExpr -> Doc ann prettyAtomExpr atomExpr = case atomExpr of - AttributeAtomExpr attrName -> "@" <> pretty attrName + AttributeAtomExpr attrName -> "@" <> prettyAttributeName attrName ConstructedAtomExpr dConsName [] () -> pretty dConsName ConstructedAtomExpr dConsName atomExprs () -> parens (pretty dConsName <+> hsep (map prettyAtomExpr atomExprs)) _ -> pretty atomExpr @@ -60,9 +63,13 @@ prettyAtomExprsAsArguments :: [AtomExpr] -> Doc ann prettyAtomExprsAsArguments = align . parensList . map addAt where addAt (atomExpr :: AtomExpr) = case atomExpr of - AttributeAtomExpr attrName -> "@" <> pretty attrName + AttributeAtomExpr attrName -> "@" <> prettyAttributeName attrName _ -> pretty atomExpr +nameNeedsQuoting :: StringType -> Bool +nameNeedsQuoting s = + isLeft (parse uncapitalizedIdentifier "" s) + instance Pretty UUID where pretty = pretty . show @@ -83,7 +90,7 @@ instance Pretty Attribute where instance Pretty RelationalExpr where pretty (RelationVariable n _) = pretty n pretty (ExistingRelation r) = pretty r - pretty (RelationValuedAttribute attrName) = "@" <> pretty attrName + pretty (RelationValuedAttribute attrName) = "@" <> prettyAttributeName attrName pretty (NotEquals a b) = pretty' a <+> "!=" <+> pretty' b pretty (Equals a b) = pretty' a <+> "==" <+> pretty' b pretty (Project ns r) = pretty' (ignoreProjects r) <> pretty ns @@ -118,15 +125,15 @@ pretty' :: RelationalExpr -> Doc n pretty' = prettyRelationalExpr instance Pretty AttributeNames where - pretty (AttributeNames attrNames) = prettyBracesList (S.toList attrNames) - pretty (InvertedAttributeNames attrNames) = braces $ "all but" <+> concatWith (surround ", ") (map pretty (S.toList attrNames)) + pretty (AttributeNames attrNames) = bracesList (map prettyAttributeName (S.toList attrNames)) + pretty (InvertedAttributeNames attrNames) = braces $ "all but" <+> concatWith (surround ", ") (map prettyAttributeName (S.toList attrNames)) pretty (RelationalExprAttributeNames relExpr) = braces $ "all from" <+> pretty relExpr pretty (UnionAttributeNames aAttrNames bAttrNames) = braces ("union of" <+> pretty aAttrNames <+> pretty bAttrNames) pretty (IntersectAttributeNames aAttrNames bAttrNames) = braces ("intersection of" <+> pretty aAttrNames <+> pretty bAttrNames) instance Pretty AttributeExpr where pretty (NakedAttributeExpr attr) = pretty attr - pretty (AttributeAndTypeNameExpr name typeCons _) = pretty name <+> pretty typeCons + pretty (AttributeAndTypeNameExpr name typeCons _) = prettyAttributeName name <+> pretty typeCons instance Pretty TypeConstructor where pretty (ADTypeConstructor tcName []) = pretty tcName @@ -157,7 +164,7 @@ instance Pretty ExtendTupleExpr where newtype RenameTuple = RenameTuple { _unRenameTuple :: (AttributeName, AttributeName) } instance Pretty RenameTuple where - pretty (RenameTuple (n1, n2)) = pretty n1 <+> "as" <+> pretty n2 + pretty (RenameTuple (n1, n2)) = pretty n1 <+> "as" <+> prettyAttributeName n2 instance Pretty RestrictionPredicateExpr where @@ -170,7 +177,8 @@ instance Pretty RestrictionPredicateExpr where pretty (AttributeEqualityPredicate attrName atomExpr) = prettyAttributeName attrName <> "=" <> pretty atomExpr prettyAttributeName :: AttributeName -> Doc a -prettyAttributeName attrName = pretty $ "`" <> attrName <> "`" +prettyAttributeName attrName | nameNeedsQuoting attrName = pretty $ "`" <> attrName <> "`" +prettyAttributeName attrName = pretty $ attrName instance Pretty WithNameExpr where pretty (WithNameExpr name _) = pretty name @@ -236,7 +244,7 @@ instance Pretty DatabaseContextExpr where instance Pretty AttributeNameAtomExprMap where pretty m = - group (encloseSep "(" ")" "," (map (\(attrName, atomExpr) -> pretty attrName <+> ":=" <+> pretty atomExpr) (M.toList m))) + group (encloseSep "(" ")" "," (map (\(attrName, atomExpr) -> prettyAttributeName attrName <+> ":=" <+> pretty atomExpr) (M.toList m))) instance Pretty TypeConstructorDef where pretty (ADTypeConstructorDef tConsName tVarNames) = pretty tConsName <+> hsep (pretty <$> tVarNames) diff --git a/src/lib/ProjectM36/DatabaseContext.hs b/src/lib/ProjectM36/DatabaseContext.hs index 3359c12f..6896f90d 100644 --- a/src/lib/ProjectM36/DatabaseContext.hs +++ b/src/lib/ProjectM36/DatabaseContext.hs @@ -43,3 +43,9 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty, registeredQueries = M.singleton "booleans" (Union (RelationVariable "true" ()) (RelationVariable "false" ())) } +someDatabaseContextExprs :: [DatabaseContextExpr] -> DatabaseContextExpr +someDatabaseContextExprs [s] = s +someDatabaseContextExprs (s:ss) = MultipleExpr (s:ss) +someDatabaseContextExprs [] = NoOperation + + diff --git a/src/lib/ProjectM36/InclusionDependency.hs b/src/lib/ProjectM36/InclusionDependency.hs index 88e54565..09dbffcf 100644 --- a/src/lib/ProjectM36/InclusionDependency.hs +++ b/src/lib/ProjectM36/InclusionDependency.hs @@ -16,4 +16,15 @@ inclusionDependenciesAsRelation incDeps = incDepAsAtoms (name, InclusionDependency exprA exprB) = [TextAtom name, RelationalExprAtom exprA, RelationalExprAtom exprB] - + +-- validate that the given AtomExpr is true for an relvar +inclusionDependencyForAtomExpr :: RelVarName -> AtomExpr -> InclusionDependency +inclusionDependencyForAtomExpr rvname atomExpr = + InclusionDependency + (NotEquals (ExistingRelation relationTrue) + (Project (AttributeNames mempty) (Restrict check (RelationVariable rvname ()))) + ) + (ExistingRelation relationFalse) + where + check = AtomExprPredicate atomExpr + diff --git a/src/lib/ProjectM36/Key.hs b/src/lib/ProjectM36/Key.hs index 455c09ca..246fa2b3 100644 --- a/src/lib/ProjectM36/Key.hs +++ b/src/lib/ProjectM36/Key.hs @@ -2,6 +2,7 @@ module ProjectM36.Key where import ProjectM36.Base import ProjectM36.Relation import qualified Data.Set as S +import qualified Data.Text as T #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif @@ -37,7 +38,9 @@ inclusionDependencyForKey attrNames relExpr = --InclusionDependency name (exprCo -- | Create a 'DatabaseContextExpr' which can be used to add a uniqueness constraint to attributes on one relation variable. databaseContextExprForUniqueKey :: RelVarName -> [AttributeName] -> DatabaseContextExpr -databaseContextExprForUniqueKey rvName attrNames = AddInclusionDependency (rvName <> "_key") $ inclusionDependencyForKey (AttributeNames (S.fromList attrNames)) (RelationVariable rvName ()) +databaseContextExprForUniqueKey rvName attrNames = AddInclusionDependency (rvName <> "_" <> cols <> "_key") $ inclusionDependencyForKey (AttributeNames (S.fromList attrNames)) (RelationVariable rvName ()) + where + cols = T.intercalate "_" attrNames -- | Create a foreign key constraint from the first relation variable and attributes to the second. databaseContextExprForForeignKey :: IncDepName -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> DatabaseContextExpr diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 0e8f6c34..cf984363 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -5,7 +5,9 @@ import ProjectM36.Base as B import ProjectM36.Error import ProjectM36.DataTypes.SQL.Null import ProjectM36.SQL.Select +import ProjectM36.DatabaseContext (someDatabaseContextExprs) import ProjectM36.SQL.Insert as Insert +import ProjectM36.Key (databaseContextExprForUniqueKey, inclusionDependencyForKey) import ProjectM36.SQL.DBUpdate import ProjectM36.SQL.Update as Update import ProjectM36.SQL.Delete as Delete @@ -1137,11 +1139,16 @@ convertUpdate typeF up = do let convertSetColumns (UnqualifiedColumnName colName, sexpr) = do (,) <$> pure colName <*> convertScalarExpr typeF sexpr atomMap <- M.fromList <$> mapM convertSetColumns (setColumns up) - restrictionExpr <- case mRestriction up of - Nothing -> pure TruePredicate - Just restriction' -> convertWhereClause typeF restriction' rvname <- convertTableName (Update.target up) - pure (B.Update rvname atomMap restrictionExpr) + let rv = RelationVariable rvname () + case typeF rv of + Left err -> throwSQLE (SQLRelationalError err) + Right typeRel -> do + _ <- insertTable (TableAlias rvname) rv (attributes typeRel) + restrictionExpr <- case mRestriction up of + Nothing -> pure TruePredicate + Just restriction' -> convertWhereClause typeF restriction' + pure (B.Update rvname atomMap restrictionExpr) convertTableName :: TableName -> ConvertM RelVarName convertTableName (TableName [tname]) = pure tname @@ -1195,37 +1202,75 @@ convertDelete typeF del = do convertCreateTable :: TypeForRelExprF -> CreateTable -> ConvertM DatabaseContextExpr convertCreateTable _typeF ct = do rvTarget <- convertTableName (CreateTable.target ct) - attrs <- convertColumnNamesAndTypes (CreateTable.targetColumns ct) - pure (Define rvTarget attrs) + (attrs, constraintExprs) <- convertColumnNamesAndTypes rvTarget (CreateTable.targetColumns ct) + pure (someDatabaseContextExprs (Define rvTarget attrs : constraintExprs)) convertDropTable :: TypeForRelExprF -> DropTable -> ConvertM DatabaseContextExpr convertDropTable _typeF dt = do rvTarget <- convertTableName (DropTable.target dt) pure (Undefine rvTarget) -convertColumnNamesAndTypes :: [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)] -> ConvertM [AttributeExpr] -convertColumnNamesAndTypes colAssocs = - mapM mkAttributeExpr colAssocs +convertColumnNamesAndTypes :: RelVarName -> [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)] -> ConvertM ([AttributeExpr], [DatabaseContextExpr]) +convertColumnNamesAndTypes rvName colAssocs = + foldM processColumn mempty colAssocs where - mkAttributeExpr (UnqualifiedColumnName colName, colType, constraints) = do - aType <- convertColumnType colType constraints - pure $ NakedAttributeExpr (Attribute colName aType) - -convertColumnType :: ColumnType -> PerColumnConstraints -> ConvertM AtomType -convertColumnType colType constraints = - mkAtomType $ - case colType of - IntegerColumnType -> IntegerAtomType - TextColumnType -> TextAtomType - BoolColumnType -> BoolAtomType - DoubleColumnType -> DoubleAtomType - DateTimeColumnType -> DateTimeAtomType + processColumn acc (ucn@(UnqualifiedColumnName colName), colType, constraints) = do + aTypeCons <- convertColumnType colType constraints + constraintExprs <- convertPerColumnConstraints rvName ucn constraints + pure $ ( fst acc <> [AttributeAndTypeNameExpr colName aTypeCons ()], + constraintExprs <> snd acc) + +convertColumnType :: ColumnType -> PerColumnConstraints -> ConvertM TypeConstructor +convertColumnType colType constraints = do + let mkTypeCons aType = + let typeName = T.dropEnd (length ("AtomType"::String)) (T.pack (show aType)) + tCons = ADTypeConstructor typeName [] + in + if notNullConstraint constraints then + tCons + else + ADTypeConstructor "SQLNullable" [tCons] + colTCons = mkTypeCons $ + case colType of + IntegerColumnType -> IntegerAtomType + TextColumnType -> TextAtomType + BoolColumnType -> BoolAtomType + DoubleColumnType -> DoubleAtomType + DateTimeColumnType -> DateTimeAtomType + DateColumnType -> DayAtomType + ByteaColumnType -> ByteStringAtomType + pure (colTCons) + +convertPerColumnConstraints :: RelVarName -> UnqualifiedColumnName -> PerColumnConstraints -> ConvertM [DatabaseContextExpr] +convertPerColumnConstraints rvname (UnqualifiedColumnName colName) constraints = do + -- NOT NULL constraints are already enforced by the column type + fkExprs <- case references constraints of + Nothing -> pure [] + Just (TableName [fkTableName], UnqualifiedColumnName fkColName) -> do + let fkIncDepName = rvname <> "_" <> colName <> "__" <> fkTableName <> "_" <> fkColName <> "_fk" + mkFK = InclusionDependency (Project (AttributeNames (S.singleton colName)) (RelationVariable rvname ())) (Project (AttributeNames (S.singleton fkColName)) (RelationVariable fkTableName ())) + + pure [AddInclusionDependency fkIncDepName mkFK] + Just (TableName fkTableNames, UnqualifiedColumnName fkColName) -> + throwSQLE (NotSupportedError ("schema-qualified table name in fk constraint: " <> T.pack (show fkTableNames) <> " " <> fkColName)) + -- the uniqueness constraint in SQL does not consider NULLs to be equal by default + let uniqueExprs = if uniquenessConstraint constraints then + if notNullConstraint constraints then + [databaseContextExprForUniqueKey rvname [colName]] + else + [databaseContextExprForUniqueKeyWithNull rvname colName] + else + [] + pure $ uniqueExprs <> fkExprs + +databaseContextExprForUniqueKeyWithNull :: RelVarName -> AttributeName -> DatabaseContextExpr +databaseContextExprForUniqueKeyWithNull rvname attrName = + AddInclusionDependency incDepName incDep where - mkAtomType aType = - pure $ if notNullConstraint constraints then - aType - else - nullAtomType aType + incDep = inclusionDependencyForKey (AttributeNames (S.singleton attrName)) (Restrict notNull (RelationVariable rvname ())) + incDepName = rvname <> "_" <> attrName <> "_unique" + notNull = NotPredicate (AtomExprPredicate (FunctionAtomExpr "sql_isnull" [AttributeAtomExpr attrName] ())) + {- select city,max(status) from s group by city; diff --git a/src/lib/ProjectM36/SQL/CreateTable.hs b/src/lib/ProjectM36/SQL/CreateTable.hs index 157372ff..b6958e34 100644 --- a/src/lib/ProjectM36/SQL/CreateTable.hs +++ b/src/lib/ProjectM36/SQL/CreateTable.hs @@ -17,13 +17,17 @@ data ColumnType = TextColumnType | BoolColumnType | DoubleColumnType | - DateTimeColumnType + DateTimeColumnType | -- timestamp with timezone + DateColumnType | + ByteaColumnType deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant ColumnType -- | Used to represent constraints which are defined next to a column name and type. data PerColumnConstraints = PerColumnConstraints { - notNullConstraint :: Bool + notNullConstraint :: Bool, + uniquenessConstraint :: Bool, + references :: Maybe (TableName, UnqualifiedColumnName) } deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryVariant PerColumnConstraints diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 5ee95509..6b8cd1cf 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -3,6 +3,8 @@ import SQL.Interpreter.Select import ProjectM36.SQL.Convert import ProjectM36.SQL.Select import TutorialD.Interpreter.RODatabaseContextOperator +import TutorialD.Interpreter.DatabaseContextExpr +import SQL.Interpreter.CreateTable import ProjectM36.DataTypes.SQL.Null import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph @@ -25,7 +27,7 @@ main = do tcounts <- runTestTT (TestList tests) if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess where - tests = [testFindColumn, testSelect] + tests = [testFindColumn, testSelect, testCreateTable] testFindColumn :: Test @@ -302,12 +304,75 @@ testSelect = TestCase $ do Left err -> assertFailure (show err <> ": " <> show tutdAsDFExpr) Right rel -> pure rel eConfirmationEvald <- executeDataFrameExpr sess conn confirmationDFExpr - print ("confirmation"::String, confirmation_tutd) +-- print ("confirmation"::String, confirmation_tutd) confirmationResult <- case eConfirmationEvald of Left err -> assertFailure (show err <> ": " <> show confirmationDFExpr) Right rel -> pure rel assertEqual "SQL result confirmation" confirmationResult sqlResult - mapM_ check readTests + mapM_ check readTests + +testCreateTable :: Test +testCreateTable = TestCase $ do + let sqlDBContext = dateExamples { relationVariables = M.insert "snull" (ExistingRelation s_nullRelVar) (relationVariables dateExamples) } + (tgraph,transId) <- freshTransactionGraph sqlDBContext + + let createTableTests = [ + --no columns + ("create table test()", + "test :: {}" + ), + --simple column + ("create table test(col1 integer)", + "test :: {col1 SQLNullable Integer}" + ), + --not null + ("create table test(col1 integer not null)", + "test :: {col1 Integer}" + ), + ("create table test(col1 integer, \"col2\" text not null)", + "test :: {col1 SQLNullable Integer, col2 Text}" + ), + -- foreign key "references" + ("create table test(col1 integer, col2 integer references test2(pk))", + "test :: {col1 SQLNullable Integer, col2 SQLNullable Integer}; foreign key test_col2__test2_pk_fk test{col2} in test2{pk}"), + -- uniqueness constraint + ("create table test(col1 integer unique)", + "test :: {col1 SQLNullable Integer}; key test_col1_unique {col1} test where not(sql_isnull(@col1))"), + -- primary key (equivalent to uniqueness constraint + not null) + ("create table test(col1 integer primary key)", + "test :: {col1 Integer}; key test_col1_key {col1} test") + ] + parseTutd tutd = do + case parse (multipleDatabaseContextExprP <* eof) "test" tutd of + Left err -> assertFailure (errorBundlePretty err) + Right x -> do + pure x + gfEnv = GraphRefRelationalExprEnv { + gre_context = Just sqlDBContext, + gre_graph = tgraph, + gre_extra = mempty } + typeF expr = do + let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr) + runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) + + check (sql, equivalent_tutd) = do + --parse SQL + query <- case parse (createTableP <* eof) "test" sql of + Left err -> assertFailure (errorBundlePretty err) + Right x -> do + --print ("parsed SQL:"::String, x) + pure x + --parse tutd + tutdAsDFExpr <- parseTutd equivalent_tutd + queryAsDFExpr <- case evalConvertM mempty (convertCreateTable typeF query) of + Left err -> assertFailure (show err) + Right x -> do + --print ("convert SQL->tutd:"::String, x) + pure x + print sql + assertEqual "create table SQL" tutdAsDFExpr queryAsDFExpr + + mapM_ check createTableTests -- assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection) From 7aa767b205c89410331091d69eed40df0515b2e7 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 13 May 2024 01:33:18 -0400 Subject: [PATCH 091/170] implement hlint suggestions --- src/bin/ProjectM36/Cli.hs | 2 +- src/bin/SQL/Interpreter/Base.hs | 8 +- src/bin/SQL/Interpreter/CreateTable.hs | 13 +-- src/bin/SQL/Interpreter/ImportBasicExample.hs | 2 +- src/bin/SQL/Interpreter/Select.hs | 14 +-- .../Interpreter/TransactionGraphOperator.hs | 5 +- src/bin/TutorialD/Interpreter.hs | 2 +- src/bin/TutorialD/Interpreter/Base.hs | 2 +- .../Interpreter/RODatabaseContextOperator.hs | 3 +- .../TutorialD/Interpreter/RelationalExpr.hs | 3 +- src/bin/TutorialD/Printer.hs | 2 +- src/lib/ProjectM36/Relation.hs | 8 +- src/lib/ProjectM36/RelationalExpression.hs | 2 +- src/lib/ProjectM36/SQL/Convert.hs | 91 +++++++++---------- src/lib/ProjectM36/SQL/CreateTable.hs | 2 +- src/lib/ProjectM36/SQL/DBUpdate.hs | 2 +- src/lib/ProjectM36/SQL/Delete.hs | 2 +- src/lib/ProjectM36/SQL/DropTable.hs | 4 +- src/lib/ProjectM36/SQL/Insert.hs | 2 +- src/lib/ProjectM36/SQL/Select.hs | 48 +++++----- src/lib/ProjectM36/SQL/Update.hs | 2 +- src/lib/ProjectM36/StaticOptimizer.hs | 4 +- src/lib/ProjectM36/TransactionGraph.hs | 2 +- test/SQL/InterpreterTest.hs | 10 +- 24 files changed, 116 insertions(+), 119 deletions(-) diff --git a/src/bin/ProjectM36/Cli.hs b/src/bin/ProjectM36/Cli.hs index 2ec8c234..95f5411c 100644 --- a/src/bin/ProjectM36/Cli.hs +++ b/src/bin/ProjectM36/Cli.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} -- functions common to both tutd and sqlegacy command line interfaces module ProjectM36.Cli where import qualified ProjectM36.Client as C diff --git a/src/bin/SQL/Interpreter/Base.hs b/src/bin/SQL/Interpreter/Base.hs index b851c94b..6c45950a 100644 --- a/src/bin/SQL/Interpreter/Base.hs +++ b/src/bin/SQL/Interpreter/Base.hs @@ -4,6 +4,7 @@ import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as Lex import Data.Text as T (Text, singleton, pack, splitOn, toLower) +import Data.Functor (($>)) -- consumes only horizontal spaces spaceConsumer :: Parser () @@ -23,8 +24,7 @@ reserveds words' = do reserveds' words'' reserveds' :: [Text] -> Parser () -reserveds' words' = - sequence_ (map reserved words') +reserveds' = mapM_ reserved -- does not consume trailing spaces qualifiedNameSegment :: Text -> Parser Text @@ -51,7 +51,7 @@ identifierRemainder c = do pure (pack (c:rest)) symbol :: Text -> Parser Text -symbol sym = Lex.symbol spaceConsumer sym +symbol = Lex.symbol spaceConsumer comma :: Parser Text comma = symbol "," @@ -86,7 +86,7 @@ quotedIdentifier = (T.pack <$> (doubleQuote *> many (escapedDoubleQuote <|> notDoubleQuote) <* doubleQuote)) <* spaceConsumer where doubleQuote = char '"' - escapedDoubleQuote = chunk "\"\"" *> pure '"' + escapedDoubleQuote = chunk "\"\"" $> '"' notDoubleQuote = satisfy ('"' /=) diff --git a/src/bin/SQL/Interpreter/CreateTable.hs b/src/bin/SQL/Interpreter/CreateTable.hs index c2f9722a..527fb0d2 100644 --- a/src/bin/SQL/Interpreter/CreateTable.hs +++ b/src/bin/SQL/Interpreter/CreateTable.hs @@ -6,6 +6,7 @@ import SQL.Interpreter.Base import ProjectM36.Interpreter import Text.Megaparsec import Control.Monad.Permutations +import Data.Functor (($>)) createTableP :: Parser CreateTable createTableP = do @@ -25,7 +26,7 @@ columnNamesAndTypesP = pure (colName, colType, perColConstraints) columnTypeP :: Parser ColumnType -columnTypeP = choice (map (\(nam, typ) -> reserved nam *> pure typ) types) +columnTypeP = choice (map (\(nam, typ) -> reserved nam $> typ) types) where types = [("integer", IntegerColumnType), ("int", IntegerColumnType), @@ -50,11 +51,11 @@ perColConstraintsP :: Parser PerColumnConstraints perColConstraintsP = do parsed <- runPermutation $ PerColumnConstraintsParse <$> - toPermutationWithDefault False (try (reserveds "not null" *> pure True)) <*> - toPermutationWithDefault False (reserved "unique" *> pure True) <*> - toPermutationWithDefault False (reserved "primary key" *> pure True) <*> + toPermutationWithDefault False (try (reserveds "not null" $> True)) <*> + toPermutationWithDefault False (reserved "unique" $> True) <*> + toPermutationWithDefault False (reserved "primary key" $> True) <*> toPermutationWithDefault Nothing (Just <$> referencesP) - pure (PerColumnConstraints { notNullConstraint = (parse_notNullConstraint parsed) || (parse_primaryKeyConstraint parsed), - uniquenessConstraint = (parse_uniquenessConstraint parsed) || (parse_primaryKeyConstraint parsed), + pure (PerColumnConstraints { notNullConstraint = parse_notNullConstraint parsed || parse_primaryKeyConstraint parsed, + uniquenessConstraint = parse_uniquenessConstraint parsed || parse_primaryKeyConstraint parsed, references = parse_references parsed }) diff --git a/src/bin/SQL/Interpreter/ImportBasicExample.hs b/src/bin/SQL/Interpreter/ImportBasicExample.hs index c5f558a9..e464d2f5 100644 --- a/src/bin/SQL/Interpreter/ImportBasicExample.hs +++ b/src/bin/SQL/Interpreter/ImportBasicExample.hs @@ -3,7 +3,7 @@ import qualified Data.Text as T import SQL.Interpreter.Base import ProjectM36.Interpreter -data ImportBasicExampleOperator = ImportBasicExampleOperator T.Text +newtype ImportBasicExampleOperator = ImportBasicExampleOperator T.Text deriving (Show) importBasicExampleP :: Parser ImportBasicExampleOperator diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index c457ecb0..1e04288d 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, DeriveTraversable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module SQL.Interpreter.Select where import ProjectM36.Interpreter import ProjectM36.SQL.Select @@ -31,7 +31,7 @@ queryP = E.makeExprParser queryTermP queryOpP infixOpP nam op = E.InfixL $ do reserved nam - pure (\a b -> QueryOp op a b) + pure (QueryOp op) valuesP :: Parser [[ScalarExpr]] valuesP = do @@ -77,7 +77,7 @@ tableExprP = fromP :: Parser [TableRef] fromP = reserved "from" *> (concat <$> sepByComma trefs) where - trefs = ((:) <$> nonJoinTref <*> many joinP) + trefs = (:) <$> nonJoinTref <*> many joinP nonJoinTref = choice [parens $ QueryTableRef <$> selectP, try (AliasedTableRef <$> simpleRef <*> (reserved "as" *> tableAliasP)), simpleRef] @@ -123,7 +123,7 @@ havingP = reserved "having" *> (HavingExpr <$> scalarExprP) orderByP :: Parser [SortExpr] orderByP = - reserveds "order by" *> (sepByComma1 (SortExpr <$> scalarExprP <*> optional directionP <*> optional nullsOrderP)) + reserveds "order by" *> sepByComma1 (SortExpr <$> scalarExprP <*> optional directionP <*> optional nullsOrderP) where directionP = (reserved "asc" $> Ascending) <|> (reserved "desc" $> Descending) @@ -179,7 +179,7 @@ scalarExprOp = binarySymbolL s = E.InfixL $ binary s binary s = do op <- qualifiedOperatorP s - pure (\a b -> BinaryOperator a op b) + pure (`BinaryOperator` op) binarySymbolR s = E.InfixR $ binary s binarySymbolN s = E.InfixN $ binary s qComparisonOp = E.Postfix $ try quantifiedComparisonSuffixP @@ -280,7 +280,7 @@ stringLiteralP = StringLiteral <$> stringP nullLiteralP :: Parser (ScalarExprBase a) nullLiteralP = - reserved "NULL" *> pure NullLiteral + reserved "NULL" $> NullLiteral scalarTermP :: QualifiedNameP a => Parser (ScalarExprBase a) scalarTermP = choice [ @@ -359,7 +359,7 @@ offsetP = optional (reserved "offset" *> integer) withP :: Parser WithClause withP = do reserved "with" - recursive <- try (reserved "recursive" *> pure True) <|> pure False + recursive <- try (reserved "recursive" $> True) <|> pure False wExprs <- sepByComma1 $ do wName <- withExprAliasP reserved "as" diff --git a/src/bin/SQL/Interpreter/TransactionGraphOperator.hs b/src/bin/SQL/Interpreter/TransactionGraphOperator.hs index 193e1c7c..fd25cef4 100644 --- a/src/bin/SQL/Interpreter/TransactionGraphOperator.hs +++ b/src/bin/SQL/Interpreter/TransactionGraphOperator.hs @@ -2,6 +2,7 @@ module SQL.Interpreter.TransactionGraphOperator where import ProjectM36.Interpreter import SQL.Interpreter.Base import Control.Applicative +import Data.Functor (($>)) data TransactionGraphOperator = Commit | Rollback deriving (Show, Eq) @@ -10,7 +11,7 @@ transactionGraphOperatorP :: Parser TransactionGraphOperator transactionGraphOperatorP = commitP <|> rollbackP commitP :: Parser TransactionGraphOperator -commitP = reserved "commit" *> pure Commit +commitP = reserved "commit" $> Commit rollbackP :: Parser TransactionGraphOperator -rollbackP = reserved "rollback" *> pure Rollback +rollbackP = reserved "rollback" $> Rollback diff --git a/src/bin/TutorialD/Interpreter.hs b/src/bin/TutorialD/Interpreter.hs index 3babc698..a6f0dfb2 100644 --- a/src/bin/TutorialD/Interpreter.hs +++ b/src/bin/TutorialD/Interpreter.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase, CPP #-} +{-# LANGUAGE GADTs, CPP #-} module TutorialD.Interpreter where import ProjectM36.Interpreter import TutorialD.Interpreter.Base diff --git a/src/bin/TutorialD/Interpreter/Base.hs b/src/bin/TutorialD/Interpreter/Base.hs index 06f9a9b9..b2b7a591 100644 --- a/src/bin/TutorialD/Interpreter/Base.hs +++ b/src/bin/TutorialD/Interpreter/Base.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, CPP #-} +{-# LANGUAGE CPP #-} module TutorialD.Interpreter.Base ( module TutorialD.Interpreter.Base, module Text.Megaparsec, diff --git a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs index 9a1ecc6c..c52c10de 100644 --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -203,8 +203,7 @@ interpretRODatabaseContextOp sessionId conn tutdstring = case parse roDatabaseCo showDataFrameP :: Parser RODatabaseContextOperator showDataFrameP = do colonOp ":showdataframe" - dfExpr <- dataFrameP - pure (ShowDataFrame dfExpr) + ShowDataFrame <$> dataFrameP dataFrameP :: Parser DF.DataFrameExpr dataFrameP = do diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs index 22bd27de..1df0f43c 100644 --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -245,8 +245,7 @@ ifThenAtomExprP = do reserved "then" thenE <- atomExprP reserved "else" - elseE <- atomExprP - pure (IfThenAtomExpr ifE thenE elseE) + IfThenAtomExpr ifE thenE <$> atomExprP functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) functionAtomExprP = diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index bd0fed17..1b2967b0 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -178,7 +178,7 @@ instance Pretty RestrictionPredicateExpr where prettyAttributeName :: AttributeName -> Doc a prettyAttributeName attrName | nameNeedsQuoting attrName = pretty $ "`" <> attrName <> "`" -prettyAttributeName attrName = pretty $ attrName +prettyAttributeName attrName = pretty attrName instance Pretty WithNameExpr where pretty (WithNameExpr name _) = pretty name diff --git a/src/lib/ProjectM36/Relation.hs b/src/lib/ProjectM36/Relation.hs index e87d26ad..b01687c5 100644 --- a/src/lib/ProjectM36/Relation.hs +++ b/src/lib/ProjectM36/Relation.hs @@ -80,12 +80,12 @@ singletonTuple rel@(Relation _ tupleSet) = if cardinality rel == Finite 1 then -- this is still unncessarily expensive for (bigx union bigx) because each tuple is hashed and compared for equality (when the hashes match), but the major expense is attributesEqual, but we already know that all tuple attributes are equal (it's a precondition) union :: Relation -> Relation -> Either RelationalError Relation -union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = - if not (A.attributeNameSet attrs1 == A.attributeNameSet attrs2) then +union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) + | A.attributeNameSet attrs1 /= A.attributeNameSet attrs2 = Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2)) - else if not (A.attributesEqual attrs1 attrs2) then + | not (A.attributesEqual attrs1 attrs2) = Left $ AttributeTypesMismatchError $ A.attributesDifference attrs1 attrs2 - else + | otherwise = Right $ Relation attrs1 newtuples where newtuples = tupleSetUnion attrs1 tupSet1 tupSet2 diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index a4e93402..db8d14c3 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -337,7 +337,7 @@ evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do else tmpAttrName updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr) - projectAndRename attr expr = Rename (S.singleton ((tmpAttr attr), attr)) (Project (InvertedAttributeNames (S.singleton attr)) expr) + projectAndRename attr expr = Rename (S.singleton (tmpAttr attr, attr)) (Project (InvertedAttributeNames (S.singleton attr)) expr) restrictedPortion = Restrict pred' rvExpr updated = foldr (\(oldname, atomExpr) accum -> let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index cf984363..5a15005d 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -1,5 +1,5 @@ --convert SQL into relational or database context expressions -{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables, TypeApplications, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-} module ProjectM36.SQL.Convert where import ProjectM36.Base as B import ProjectM36.Error @@ -20,23 +20,23 @@ import ProjectM36.Relation (attributes) import qualified ProjectM36.Attribute as A import qualified Data.Text as T import qualified ProjectM36.WithNameExpr as With -import Control.Monad (foldM) +import Control.Monad (foldM, when) import qualified Data.Set as S import qualified Data.Map as M import Data.List (intercalate, find) import qualified Data.Functor.Foldable as Fold import qualified Data.List.NonEmpty as NE -import Control.Monad (when) -import Data.Maybe (isJust, fromMaybe) +import Data.Maybe (isJust) --import Control.Monad (void) import Control.Monad.Trans.State (StateT, get, put, runStateT, evalStateT) import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Trans.Class (lift) import Data.Foldable (foldl') +import Data.Bifunctor (bimap) --import qualified Data.HashSet as HS -import Debug.Trace +--import Debug.Trace {- TODO @@ -226,7 +226,7 @@ noteColumnMention mTblAlias colName mColAlias = do pure (ColumnAlias newAlias) case M.lookup (TableAlias tAlias) tcontext of Nothing -> do -- add a new colaliasremapper - insertColAlias (fromMaybe tPrefixColAttr (unColumnAlias <$> mColAlias)) + insertColAlias (maybe tPrefixColAttr unColumnAlias mColAlias) Just (_, _, colAlRemapper) -> do -- table alias already known, check for column alias -- traceShowM ("noteColumnMention before attr"::String, colAlRemapper) @@ -235,17 +235,17 @@ noteColumnMention mTblAlias colName mColAlias = do -- col alias missing, so add it- figure out if it needs a table prefix --traceShowM ("findNotedColumn' in noteColumnMention"::String, colAlias) --traceStateM - let sqlColAlias = fromMaybe colAttr (unColumnAlias <$> mColAlias) - colAlias' <- case findNotedColumn' (ColumnName [colAttr]) tc of + let sqlColAlias = maybe colAttr unColumnAlias mColAlias + case findNotedColumn' (ColumnName [colAttr]) tc of Left _ -> -- no match, so table prefix not required insertColAlias sqlColAlias Right [] -> -- no match, so table prefix not required insertColAlias sqlColAlias Right [_] -> -- we have a match, so we need the table prefix - insertColAlias (fromMaybe tPrefixColAttr (unColumnAlias <$> mColAlias)) + insertColAlias (maybe tPrefixColAttr unColumnAlias mColAlias) Right (_:_) -> throwSQLE (AmbiguousColumnResolutionError colName) --traceShowM ("findNotedColumn' in noteColumnMentionB"::String, colAlias') - pure colAlias' + --pure colAlias' Right attrName -> -- we know the alias already, so return it pure (ColumnAlias attrName) @@ -262,7 +262,7 @@ noteColumnMention mTblAlias colName mColAlias = do case attributeNameForAttributeAlias colAlias colAliasRemapper of Left _ -> acc Right attrName -> (ta,attrName) : acc - sqlColAlias = fromMaybe colAlias (unColumnAlias <$> mColAlias) + sqlColAlias = maybe colAlias unColumnAlias mColAlias case foldr folder mempty (M.toList tcontext) of [] -> do -- no matches, search raw attributes @@ -290,9 +290,8 @@ lookupTable ta = do -- | Find a column name or column alias in the underlying table context. Returns key into table context. findColumn :: ColumnName -> ConvertM [TableAlias] -findColumn targetCol = do - tcontext <- get - pure (findColumn' targetCol tcontext) +findColumn targetCol = + findColumn' targetCol <$> get -- | non ConvertM version of findColumn findColumn' :: ColumnName -> TableContext -> [TableAlias] @@ -523,8 +522,8 @@ convertSubSelect typeF sel = do renamer ((TableAlias tAlias, realAttr), ColumnAlias newAttr) = (realAttr, newAttr)-} let renamedExpr = foldr renamerFolder tExpr (M.toList colRenames) - renamerFolder ((TableAlias tAlias, oldAttrName), ColumnAlias newAttrName) acc = - pushDownAttributeRename (S.singleton (oldAttrName, newAttrName)) (RelationVariable tAlias ()) acc + renamerFolder ((TableAlias tAlias, oldAttrName), ColumnAlias newAttrName)= + pushDownAttributeRename (S.singleton (oldAttrName, newAttrName)) (RelationVariable tAlias ()) pure (applyF renamedExpr) @@ -604,19 +603,19 @@ convertProjection typeF selItems groupBys havingExpr = do let projFolder (attrNames, b) (ColumnProjectionName [ProjectionName nam]) = pure (S.insert nam attrNames, b) projFolder (attrNames, b) (ColumnProjectionName [ProjectionName nameA, ProjectionName nameB]) = - pure $ (S.insert (T.concat [nameA, ".", nameB]) attrNames, b) + pure (S.insert (T.concat [nameA, ".", nameB]) attrNames, b) projFolder (attrNames, relExprAttributes) (ColumnProjectionName [ProjectionName tname, Asterisk]) = - pure $ (attrNames, relExprAttributes <> [tname]) + pure (attrNames, relExprAttributes <> [tname]) projFolder _ colProjName = throwSQLE $ UnexpectedColumnProjectionName colProjName (attrNames, relExprRvs) <- foldM projFolder mempty (S.toList (taskProjections task)) let attrsProj = A.some (map (\rv -> RelationalExprAttributeNames (RelationVariable rv ())) relExprRvs <> [AttributeNames attrNames]) pure $ Project attrsProj -- apply extensions - let fExtended = foldr (\ext acc -> (Extend ext) . acc) id (taskExtenders task) + let fExtended = foldr (\ext acc -> Extend ext . acc) id (taskExtenders task) -- process SQL aggregates by replacing projections -- let fAggregates -- apply rename - renamesSet <- foldM (\acc (qProjName, (ColumnAlias newName)) -> do + renamesSet <- foldM (\acc (qProjName, ColumnAlias newName) -> do oldName <- convertColumnProjectionName qProjName pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task) let fRenames = if S.null renamesSet then id else Rename renamesSet @@ -798,8 +797,8 @@ convertProjectionScalarExpr typeF expr = do other -> throwSQLE $ NotSupportedError ("projection scalar expr: " <> T.pack (show other)) convertOrderByClause :: TypeForRelExprF -> [SortExpr] -> ConvertM [AttributeOrderExpr] -convertOrderByClause typeF exprs = - mapM converter exprs +convertOrderByClause typeF = + mapM converter where converter (SortExpr sexpr mDirection mNullsOrder) = do atomExpr <- convertScalarExpr typeF sexpr @@ -860,7 +859,7 @@ convertTableRef typeF tref = typeRel <- wrapTypeF typeF (RelationVariable nam ()) let rv = RelationVariable nam () _ <- insertTable tAlias rv (attributes typeRel) - pure $ (tAlias, RelationVariable nam ()) + pure (tAlias, RelationVariable nam ()) x -> throwSQLE $ NotSupportedError ("table ref: " <> T.pack (show x)) @@ -1025,11 +1024,11 @@ commonAttributeNames typeF rvA rvB = Right typeB -> do let attrsA = A.attributeNameSet (attributes typeA) attrsB = A.attributeNameSet (attributes typeB) - pure $ (S.intersection attrsA attrsB, attrsA, attrsB) + pure (S.intersection attrsA attrsB, attrsA, attrsB) -- | Used to remap SQL qualified names to new names to prevent conflicts in join conditions. renameIdentifier :: (ColumnName -> ColumnName) -> ScalarExpr -> ScalarExpr -renameIdentifier renamer sexpr = Fold.cata renamer' sexpr +renameIdentifier renamer = Fold.cata renamer' where renamer' :: ScalarExprBaseF ColumnName ScalarExpr -> ScalarExpr renamer' (IdentifierF n) = Identifier (renamer n) @@ -1037,11 +1036,11 @@ renameIdentifier renamer sexpr = Fold.cata renamer' sexpr -- find all column aliases in a scalar expression- useful for determining if a renamer needs to be applied columnNamesInScalarExpr :: ScalarExpr -> S.Set ColumnName -columnNamesInScalarExpr expr = Fold.cata finder expr +columnNamesInScalarExpr = Fold.cata finder where finder :: ScalarExprBaseF ColumnName (S.Set ColumnName) -> S.Set ColumnName finder (IdentifierF n) = S.singleton n - finder exprs = foldr S.union mempty exprs + finder sexpr = foldr S.union mempty sexpr columnNamesInRestrictionExpr :: RestrictionExpr -> S.Set ColumnName columnNamesInRestrictionExpr (RestrictionExpr sexpr) = columnNamesInScalarExpr sexpr @@ -1064,8 +1063,8 @@ needsToRenameAllAttributes (RestrictionExpr sexpr) = PostfixOperator e1 _ -> rec' e1 BetweenOperator e1 _ e2 -> rec' e1 || rec' e2 FunctionApplication _ e1 -> or (rec' <$> e1) - CaseExpr cases else' -> or (map (\(when', then') -> - rec' when' || rec' then' || maybe False rec' else') cases) + CaseExpr cases else' -> any (\(when', then') -> + rec' when' || rec' then' || maybe False rec' else') cases QuantifiedComparison{} -> True InExpr _ sexpr'' _ -> rec' sexpr'' BooleanOperatorExpr e1 _ e2 -> rec' e1 || rec' e2 @@ -1102,7 +1101,7 @@ pushDownAttributeRename renameSet matchExpr targetExpr = Extend eExpr expr -> Extend (pushExtend eExpr) (push expr) With wAssocs expr -> With wAssocs (push expr) where - push expr = pushDownAttributeRename renameSet matchExpr expr + push = pushDownAttributeRename renameSet matchExpr pushRestrict expr = case expr of x@TruePredicate -> x @@ -1137,7 +1136,7 @@ mkTableContextFromDatabaseContext dbc tgraph = do convertUpdate :: TypeForRelExprF -> Update -> ConvertM DatabaseContextExpr convertUpdate typeF up = do let convertSetColumns (UnqualifiedColumnName colName, sexpr) = do - (,) <$> pure colName <*> convertScalarExpr typeF sexpr + (,) colName <$> convertScalarExpr typeF sexpr atomMap <- M.fromList <$> mapM convertSetColumns (setColumns up) rvname <- convertTableName (Update.target up) let rv = RelationVariable rvname () @@ -1211,14 +1210,14 @@ convertDropTable _typeF dt = do pure (Undefine rvTarget) convertColumnNamesAndTypes :: RelVarName -> [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)] -> ConvertM ([AttributeExpr], [DatabaseContextExpr]) -convertColumnNamesAndTypes rvName colAssocs = - foldM processColumn mempty colAssocs +convertColumnNamesAndTypes rvName = + foldM processColumn mempty where processColumn acc (ucn@(UnqualifiedColumnName colName), colType, constraints) = do aTypeCons <- convertColumnType colType constraints constraintExprs <- convertPerColumnConstraints rvName ucn constraints - pure $ ( fst acc <> [AttributeAndTypeNameExpr colName aTypeCons ()], - constraintExprs <> snd acc) + pure ( fst acc <> [AttributeAndTypeNameExpr colName aTypeCons ()], + constraintExprs <> snd acc) convertColumnType :: ColumnType -> PerColumnConstraints -> ConvertM TypeConstructor convertColumnType colType constraints = do @@ -1239,7 +1238,7 @@ convertColumnType colType constraints = do DateTimeColumnType -> DateTimeAtomType DateColumnType -> DayAtomType ByteaColumnType -> ByteStringAtomType - pure (colTCons) + pure colTCons convertPerColumnConstraints :: RelVarName -> UnqualifiedColumnName -> PerColumnConstraints -> ConvertM [DatabaseContextExpr] convertPerColumnConstraints rvname (UnqualifiedColumnName colName) constraints = do @@ -1380,12 +1379,10 @@ containsAggregate expr = PrefixOperator op e1 -> containsAggregate e1 || opAgg op PostfixOperator e1 op -> containsAggregate e1 || opAgg op BetweenOperator e1 e2 e3 -> containsAggregate e1 || containsAggregate e2 || containsAggregate e3 - FunctionApplication fname args -> isAggregateFunction fname || or (map containsAggregate args) + FunctionApplication fname args -> isAggregateFunction fname || any containsAggregate args c@CaseExpr{} -> or (cElse : concatMap (\(when', res) -> [containsAggregate res, containsAggregate when']) (caseWhens c)) where - cElse = case caseElse c of - Just e -> containsAggregate e - Nothing -> False + cElse = maybe False containsAggregate (caseElse c) q@QuantifiedComparison{} -> containsAggregate (qcExpr q) InExpr _ e1 _ -> containsAggregate e1 BooleanOperatorExpr e1 opName e2 -> opAgg opName || containsAggregate e1 || containsAggregate e2 @@ -1396,9 +1393,7 @@ containsAggregate expr = -- | Returns True iff a projection scalar expr within a larger expression. Used for group by aggregation validation. containsProjScalarExpr :: ProjectionScalarExpr -> ProjectionScalarExpr -> Bool containsProjScalarExpr needle haystack = - if needle == haystack then - True - else + (needle == haystack) || case haystack of IntegerLiteral{} -> False DoubleLiteral{} -> False @@ -1410,18 +1405,16 @@ containsProjScalarExpr needle haystack = PrefixOperator _op e1 -> con e1 PostfixOperator e1 _op -> con e1 BetweenOperator e1 e2 e3 -> con e1 || con e2 || con e3 - FunctionApplication _fname args -> or (map con args) + FunctionApplication _fname args -> any con args c@CaseExpr{} -> or (cElse : concatMap (\(when', res) -> [con res, con when']) (caseWhens c)) where - cElse = case caseElse c of - Just e -> con e - Nothing -> False + cElse = maybe False con (caseElse c) q@QuantifiedComparison{} -> con (qcExpr q) InExpr _ e1 _ -> containsAggregate e1 BooleanOperatorExpr e1 _opName e2 -> con e1 || con e2 ExistsExpr{} -> False where - con h = containsProjScalarExpr needle h + con = containsProjScalarExpr needle -- depth first replacement for scalar expr modification replaceProjScalarExpr :: (ProjectionScalarExpr -> ProjectionScalarExpr) -> ProjectionScalarExpr -> ProjectionScalarExpr @@ -1438,7 +1431,7 @@ replaceProjScalarExpr r orig = PostfixOperator e1 op -> r (PostfixOperator (recr e1) op) BetweenOperator e1 e2 e3 -> r (BetweenOperator (recr e1) (recr e2) (recr e3)) FunctionApplication fname args -> r (FunctionApplication fname (map recr args)) - c@CaseExpr{} -> r (CaseExpr { caseWhens = map (\(cond, res) -> (recr cond, recr res)) (caseWhens c), + c@CaseExpr{} -> r (CaseExpr { caseWhens = map (bimap recr recr) (caseWhens c), caseElse = recr <$> caseElse c }) c@QuantifiedComparison{} -> r (c{ qcExpr = recr (qcExpr c) }) diff --git a/src/lib/ProjectM36/SQL/CreateTable.hs b/src/lib/ProjectM36/SQL/CreateTable.hs index b6958e34..17e79eaf 100644 --- a/src/lib/ProjectM36/SQL/CreateTable.hs +++ b/src/lib/ProjectM36/SQL/CreateTable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} module ProjectM36.SQL.CreateTable where import ProjectM36.SQL.Select import Control.DeepSeq diff --git a/src/lib/ProjectM36/SQL/DBUpdate.hs b/src/lib/ProjectM36/SQL/DBUpdate.hs index 74e144a8..b7ddd33c 100644 --- a/src/lib/ProjectM36/SQL/DBUpdate.hs +++ b/src/lib/ProjectM36/SQL/DBUpdate.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} module ProjectM36.SQL.DBUpdate where import ProjectM36.SQL.Update import ProjectM36.SQL.Insert diff --git a/src/lib/ProjectM36/SQL/Delete.hs b/src/lib/ProjectM36/SQL/Delete.hs index b2056767..73542b03 100644 --- a/src/lib/ProjectM36/SQL/Delete.hs +++ b/src/lib/ProjectM36/SQL/Delete.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} module ProjectM36.SQL.Delete where import ProjectM36.SQL.Select import Control.DeepSeq diff --git a/src/lib/ProjectM36/SQL/DropTable.hs b/src/lib/ProjectM36/SQL/DropTable.hs index 27a609a2..43713d18 100644 --- a/src/lib/ProjectM36/SQL/DropTable.hs +++ b/src/lib/ProjectM36/SQL/DropTable.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} module ProjectM36.SQL.DropTable where import ProjectM36.SQL.Select import Control.DeepSeq import Codec.Winery import GHC.Generics -data DropTable = DropTable +newtype DropTable = DropTable { target :: TableName } deriving (Show, Eq, Generic, NFData) deriving Serialise via WineryRecord DropTable diff --git a/src/lib/ProjectM36/SQL/Insert.hs b/src/lib/ProjectM36/SQL/Insert.hs index 5ac6e42a..d227329e 100644 --- a/src/lib/ProjectM36/SQL/Insert.hs +++ b/src/lib/ProjectM36/SQL/Insert.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} module ProjectM36.SQL.Insert where import ProjectM36.SQL.Select import ProjectM36.Serialise.Base () diff --git a/src/lib/ProjectM36/SQL/Select.hs b/src/lib/ProjectM36/SQL/Select.hs index 679ade83..b3d39ad9 100644 --- a/src/lib/ProjectM36/SQL/Select.hs +++ b/src/lib/ProjectM36/SQL/Select.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, DeriveTraversable, GeneralizedNewtypeDeriving, DerivingVia, DeriveAnyClass, DeriveGeneric, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveTraversable, GeneralizedNewtypeDeriving, DerivingVia, DeriveAnyClass, DeriveGeneric, StandaloneDeriving, FlexibleInstances #-} module ProjectM36.SQL.Select where import qualified Data.List.NonEmpty as NE import Data.Text (Text) @@ -134,15 +134,17 @@ data InPredicateValue = InList [ScalarExpr] | InQueryExpr Select | InScalarExpr deriving Serialise via WineryVariant InPredicateValue deriving Hashable -data GroupByExpr = GroupByExpr ProjectionScalarExpr - deriving (Show, Eq, Generic, NFData) +newtype GroupByExpr = GroupByExpr ProjectionScalarExpr + deriving (Show, Eq, Generic) deriving Serialise via WineryVariant GroupByExpr - deriving Hashable + deriving newtype Hashable + deriving newtype NFData -data HavingExpr = HavingExpr ProjectionScalarExpr - deriving (Show, Eq, Generic, NFData) +newtype HavingExpr = HavingExpr ProjectionScalarExpr + deriving (Show, Eq, Generic) deriving Serialise via WineryVariant HavingExpr - deriving Hashable + deriving newtype Hashable + deriving newtype NFData data SortExpr = SortExpr ScalarExpr (Maybe Direction) (Maybe NullsOrder) deriving (Show, Eq, Generic, NFData) @@ -174,35 +176,37 @@ newtype JoinOnCondition = JoinOnCondition ScalarExpr deriving newtype NFData deriving newtype Hashable -data ColumnProjectionName = ColumnProjectionName [ProjectionName] --dot-delimited reference - deriving (Show, Eq, Ord, Generic, NFData) +newtype ColumnProjectionName = ColumnProjectionName [ProjectionName] --dot-delimited reference + deriving (Show, Eq, Ord, Generic) deriving Serialise via WineryVariant ColumnProjectionName - -instance Hashable ColumnProjectionName + deriving newtype NFData + deriving newtype Hashable data ProjectionName = ProjectionName Text | Asterisk deriving (Show, Eq, Ord, Generic, NFData) deriving Serialise via WineryVariant ProjectionName deriving Hashable -data ColumnName = ColumnName [Text] - deriving (Show, Eq, Ord, Generic, NFData) +newtype ColumnName = ColumnName [Text] + deriving (Show, Eq, Ord, Generic) deriving Serialise via WineryVariant ColumnName - deriving Hashable + deriving newtype Hashable + deriving newtype NFData -data UnqualifiedColumnName = UnqualifiedColumnName Text - deriving (Show, Eq, Ord, Generic, NFData) +newtype UnqualifiedColumnName = UnqualifiedColumnName Text + deriving (Show, Eq, Ord, Generic) deriving Serialise via WineryVariant UnqualifiedColumnName - deriving Hashable + deriving newtype (Hashable, NFData) -data TableName = TableName [Text] - deriving (Show, Eq, Ord, Generic, NFData) +newtype TableName = TableName [Text] + deriving (Show, Eq, Ord, Generic) deriving Serialise via WineryVariant TableName - deriving Hashable + deriving newtype (Hashable, NFData) -data OperatorName = OperatorName [Text] - deriving (Show, Eq, Ord, Generic, NFData) +newtype OperatorName = OperatorName [Text] + deriving (Show, Eq, Ord, Generic) deriving Serialise via WineryVariant OperatorName + deriving newtype NFData instance Hashable OperatorName diff --git a/src/lib/ProjectM36/SQL/Update.hs b/src/lib/ProjectM36/SQL/Update.hs index 297aa328..da214979 100644 --- a/src/lib/ProjectM36/SQL/Update.hs +++ b/src/lib/ProjectM36/SQL/Update.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia, DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} module ProjectM36.SQL.Update where import ProjectM36.SQL.Select import ProjectM36.Serialise.Base () diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index ecb9d0d9..ecbf3399 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -591,13 +591,13 @@ applyStaticRestrictionPushdown expr = case expr of -- if the rename is completely redundant because it renames an attribute name to the same attribute name, remove it -- Rename [(x,x)] == Rename [] applyRedundantRenameCleanup :: GraphRefRelationalExpr -> GraphRefRelationalExpr -applyRedundantRenameCleanup expr = Fold.cata folder expr +applyRedundantRenameCleanup = Fold.cata folder where folder (RenameF renameSet e) = if S.null renameSet then e else - Rename (S.filter (\(a,b) -> a /= b) renameSet) e + Rename (S.filter (uncurry (/=)) renameSet) e folder e = Fold.embed e -- if the destination name in the rename is unused, we can remove it- does not detect errors if an a Rename is missing diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs index 2d9d229c..59135f10 100644 --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -467,7 +467,7 @@ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = d showTransactionStructureX :: Bool -> Transaction -> TransactionGraph -> String showTransactionStructureX showRelVars trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo ++ relVarsInfo where - relVarsInfo | showRelVars == False = "" + relVarsInfo | not showRelVars = "" | otherwise = "\n" <> concatMap show (M.toList (relationVariables (concreteDatabaseContext trans))) headInfo = maybe "" show (headNameForTransaction trans graph) parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 6b8cd1cf..cd9b24c3 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -48,7 +48,7 @@ testFindColumn = TestCase $ do testSelect :: Test testSelect = TestCase $ do -- check that SQL and tutd compile to same thing - let sqlDBContext = dateExamples { relationVariables = M.insert "snull" (ExistingRelation s_nullRelVar) (relationVariables dateExamples) } + let sqlDBContext = dateExamples { relationVariables = M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples) } (tgraph,transId) <- freshTransactionGraph sqlDBContext (sess, conn) <- dateExamplesConnection emptyNotificationCallback @@ -313,7 +313,7 @@ testSelect = TestCase $ do testCreateTable :: Test testCreateTable = TestCase $ do - let sqlDBContext = dateExamples { relationVariables = M.insert "snull" (ExistingRelation s_nullRelVar) (relationVariables dateExamples) } + let sqlDBContext = dateExamples { relationVariables = M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples) } (tgraph,transId) <- freshTransactionGraph sqlDBContext let createTableTests = [ @@ -397,11 +397,11 @@ eitherFail (Left err) = assertFailure (show err) eitherFail (Right _) = pure () addNullTable :: DatabaseContextExpr -addNullTable = Assign "snull" (ExistingRelation s_nullRelVar) +addNullTable = Assign "snull" (ExistingRelation sNullRelVar) -- snull := relation{s# Text, sname Text, status Integer, city SQLNullable Text}{tuple{s# "S1", sname "Smith", status 20, city SQLNull}} -s_nullRelVar :: Relation -s_nullRelVar = +sNullRelVar :: Relation +sNullRelVar = case mkRelationFromList attrs atomMatrix of Left err -> error (show err) Right rel -> rel From 7266dd5899448119c1a4ad18d17eb69f34ff829b Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 13 May 2024 09:36:21 -0400 Subject: [PATCH 092/170] fix updateop error reporting --- src/bin/SQL/Interpreter.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs index 1e077e83..4979402e 100644 --- a/src/bin/SQL/Interpreter.hs +++ b/src/bin/SQL/Interpreter.hs @@ -68,8 +68,10 @@ evalSQLInteractive sessionId conn safeFlag interactiveConsole command = Left err -> pure $ DisplayRelationalErrorResult err Right dbcExpr -> do let hint = renderPretty dbcExpr - _ <- eHandler $ C.executeDatabaseContextExpr sessionId conn dbcExpr - pure $ DisplayHintWith ("Equivalent TutorialD: " <> hint) QuietSuccessResult + ret <- C.executeDatabaseContextExpr sessionId conn dbcExpr + case ret of + Left err -> barf err + Right () -> pure $ DisplayHintWith ("Equivalent TutorialD: " <> hint) QuietSuccessResult TransactionGraphOp Commit -> do eHandler $ C.commit sessionId conn TransactionGraphOp Rollback -> do From 56507a779ff3b6967e470ac5ecec928972c135ab Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 24 May 2024 23:45:58 -0400 Subject: [PATCH 093/170] add support for untyped NULL, probably not complete, but tests pass --- project-m36.cabal | 7 +- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 33 +++++- src/lib/ProjectM36/RelationalExpression.hs | 49 +++++++- src/lib/ProjectM36/SQL/Convert.hs | 123 +++++++++++++++++---- test/SQL/InterpreterTest.hs | 85 ++++++++++++-- 5 files changed, 256 insertions(+), 41 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index dc7edf72..3cb96455 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -403,7 +403,12 @@ Test-Suite test-sql type: exitcode-stdio-1.0 main-is: SQL/InterpreterTest.hs Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator, ProjectM36.Interpreter, SQL.Interpreter.CreateTable - TutorialD.Printer + TutorialD.Printer, + SQL.Interpreter.DBUpdate, + SQL.Interpreter.Delete, + SQL.Interpreter.DropTable, + SQL.Interpreter.Insert, + SQL.Interpreter.Update Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific, recursion-schemes diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index a8b56fd1..4b9a31ff 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -8,6 +8,7 @@ import qualified Data.Vector as V import ProjectM36.AtomFunction import ProjectM36.Tuple import ProjectM36.Relation +import Data.Maybe (isJust) -- analogous but not equivalent to a Maybe type due to how NULLs interact with every other value @@ -17,7 +18,10 @@ nullAtomType arg = ConstructedAtomType "SQLNullable" (M.singleton "a" arg) nullTypeConstructorMapping :: TypeConstructorMapping nullTypeConstructorMapping = [(ADTypeConstructorDef "SQLNullable" ["a"], [DataConstructorDef "SQLNull" [], - DataConstructorDef "SQLJust" [DataConstructorDefTypeVarNameArg "a"]]) + DataConstructorDef "SQLJust" [DataConstructorDefTypeVarNameArg "a"]]), + -- used in SQL conversion from in expressions such as INSERT INTO s(city) VALUES (NULL) where the query expression must defer type resolution to SQLNull. + (ADTypeConstructorDef "SQLNullOfUnknownType" [], + [DataConstructorDef "SQLNullOfUnknownType" []]) ] nullAtomFunctions :: AtomFunctions @@ -119,6 +123,7 @@ coalesceBool _other = Left AtomFunctionTypeMismatchError isSQLBool :: Atom -> Bool isSQLBool atom = case atomTypeForAtom atom of ConstructedAtomType "SQLNullable" _ -> True + ConstructedAtomType "SQLNullOfUnknownType" _ -> True BoolAtomType -> True _ -> False @@ -131,6 +136,7 @@ sqlBool (ConstructedAtom dConsName aType []) | dConsName == "SQLNull" && (aType == nullAtomType BoolAtomType || aType == nullAtomType (TypeVariableType "a")) = Nothing +sqlBool (ConstructedAtom "SQLNullOfUnknownType" _ []) = Nothing sqlBool (BoolAtom tf) = Just tf sqlBool x | isSQLBool x = error "internal sqlBool type error" -- should be caught above sqlBool other = error ("sqlBool type mismatch: " <> show other) @@ -173,8 +179,22 @@ isNullOrType aType atom = atomTypeForAtom atom == nullAtomType aType || atomType isNull :: Atom -> Bool isNull (ConstructedAtom "SQLNull" (ConstructedAtomType "SQLNullable" _) []) = True +isNull (ConstructedAtom "SQLNullOfUnknownType" (ConstructedAtomType "SQLNullOfUnknownType" _) []) = True isNull _ = False +isNullAtomType :: AtomType -> Bool +isNullAtomType = isJust . atomTypeFromSQLNull + +atomTypeFromSQLNull :: AtomType -> Maybe AtomType +atomTypeFromSQLNull (ConstructedAtomType "SQLNullOfUnknownType" _) = Nothing +atomTypeFromSQLNull (ConstructedAtomType "SQLNullable" vars) + | M.size vars == 1 = + case M.elems vars of + [] -> Nothing + [t] -> Just t + _ts -> Nothing +atomTypeFromSQLNull _ = Nothing + sqlIntegerBinaryFunction :: AtomType -> (Integer -> Integer -> Atom) -> [Atom] -> Either AtomFunctionError Atom sqlIntegerBinaryFunction expectedAtomType op [a,b] | isNullOrType IntegerAtomType a && isNullOrType IntegerAtomType b = do @@ -279,3 +299,14 @@ sqlIsNull :: AtomFunctionBodyType sqlIsNull [ConstructedAtom "SQLNull" (ConstructedAtomType "SQLNullable" _) []] = pure (BoolAtom True) sqlIsNull [_arg] = pure (BoolAtom False) sqlIsNull _other = Left AtomFunctionTypeMismatchError + +isSQLNullableType :: AtomType -> Bool +isSQLNullableType (ConstructedAtomType "SQLNullable" _) = True +isSQLNullableType _ = False + +isSQLNullableSpecificType :: AtomType -> AtomType -> Bool +isSQLNullableSpecificType (ConstructedAtomType "SQLNullable" vars) expectedType | M.elems vars == [expectedType] = True +isSQLNullableSpecificType _ _ = False + +isSQLNullUnknownType :: AtomType -> Bool +isSQLNullUnknownType t = t == ConstructedAtomType "SQLNullOfUnknownType" mempty diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index db8d14c3..3896987b 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -50,7 +50,7 @@ import Control.Exception import GHC.Paths #endif -import Debug.Trace +--import Debug.Trace data DatabaseContextExprDetails = CountUpdatedTuples @@ -282,7 +282,7 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do context <- getStateContext let existingRelVar = M.lookup relVarName (relationVariables context) reEnv = freshGraphRefRelationalExprEnv (Just context) graph - eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) + case existingRelVar of Nothing -> do case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of @@ -294,13 +294,16 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel) case eExpectedType of Left err -> dbErr err - Right expectedType -> + Right expectedType -> do + -- if we are targeting an existing rv, we can morph a MakeRelationFromExprs datum to fill in missing type variables' + let hintedExpr = addTargetTypeHints (attributes expectedType) expr + eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr hintedExpr) case eNewExprType of Left err -> dbErr err Right newExprType -> do if newExprType == expectedType then do lift $ except $ validateAttributes (typeConstructorMapping context) (attributes newExprType) - setRelVar relVarName expr + setRelVar relVarName hintedExpr else dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType)) @@ -896,7 +899,7 @@ evalGraphRefAtomExpr tupIn (IfThenAtomExpr ifExpr thenExpr elseExpr) = do case conditional of BoolAtom True -> evalGraphRefAtomExpr tupIn thenExpr BoolAtom False -> evalGraphRefAtomExpr tupIn elseExpr - otherAtom -> traceShow ("evalAtom"::String, otherAtom) $ throwError (IfThenExprExpectedBooleanError (atomTypeForAtom otherAtom)) + otherAtom -> throwError (IfThenExprExpectedBooleanError (atomTypeForAtom otherAtom)) evalGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _) | tOrF == "True" = pure (BoolAtom True) | tOrF == "False" = pure (BoolAtom False) @@ -1513,4 +1516,38 @@ firstAtomForAttributeName attrName tuples = do case foldr folder Nothing tuples of Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName)) Just match -> pure match - + +-- | Optionally add type hints to resolve type variables. For example, if we are inserting into a known relvar, then we have its concrete type. +addTargetTypeHints :: Attributes -> GraphRefRelationalExpr -> GraphRefRelationalExpr +addTargetTypeHints targetAttrs expr = + case expr of + MakeRelationFromExprs Nothing tupExprs -> + MakeRelationFromExprs (Just targetAttrExprs) tupExprs + Project attrs e -> + Project attrs (hint e) + Union a b -> + Union (hint a) (hint b) + Join a b -> + Join (hint a) (hint b) + Rename rens e -> + Rename rens (hint e) + Difference a b -> + Difference (hint a) (hint b) + Group attrs gname e -> + Group attrs gname (hint e) + Ungroup gname e -> + Ungroup gname (hint e) + Restrict restriction e -> + Restrict restriction (hint e) + Equals a b -> + Equals (hint a) (hint b) + NotEquals a b -> + NotEquals (hint a) (hint b) + Extend tupExprs e -> + Extend tupExprs (hint e) + With withs e -> + With withs (hint e) + _ -> expr + where + targetAttrExprs = map NakedAttributeExpr (A.toList targetAttrs) + hint = addTargetTypeHints targetAttrs diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 5a15005d..777304a2 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -16,7 +16,7 @@ import ProjectM36.SQL.DropTable as DropTable import ProjectM36.RelationalExpression import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), Order(..), usesDataFrameFeatures) import ProjectM36.AttributeNames as A -import ProjectM36.Relation (attributes) +import ProjectM36.Relation (attributes, atomTypeForName) import qualified ProjectM36.Attribute as A import qualified Data.Text as T import qualified ProjectM36.WithNameExpr as With @@ -36,7 +36,7 @@ import Data.Foldable (foldl') import Data.Bifunctor (bimap) --import qualified Data.HashSet as HS ---import Debug.Trace +import Debug.Trace {- TODO @@ -478,7 +478,7 @@ convertSelect typeF sel = do finalRelExpr = explicitWithF (withF (projF (convertExpr dfExpr))) -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes -- apply rename reduction- this could be applied by the static query optimizer, but we do it here to simplify the tests so that they aren't polluted with redundant renames --- traceShowM ("final expr"::String, finalRelExpr) + traceShowM ("final expr"::String, finalRelExpr) pure (dfExpr { convertExpr = finalRelExpr }) @@ -732,7 +732,7 @@ convertScalarExpr typeF expr = do BooleanLiteral False -> naked (BoolAtom False) --pure $ ConstructedAtomExpr "False" [] () -- we don't have enough type context with a cast, so we default to text - NullLiteral -> pure $ ConstructedAtomExpr "SQLNull" [] () + NullLiteral -> pure $ ConstructedAtomExpr "SQLNullOfUnknownType" [] () Identifier i -> do AttributeAtomExpr <$> convertColumnName i BinaryOperator exprA op exprB -> do @@ -760,7 +760,7 @@ convertProjectionScalarExpr typeF expr = do BooleanLiteral False -> naked (BoolAtom False) --pure $ ConstructedAtomExpr "False" [] () - NullLiteral -> pure $ ConstructedAtomExpr "SQLNull" [] () + NullLiteral -> pure $ ConstructedAtomExpr "SQLNullOfUnknownType" [] () Identifier i -> do AttributeAtomExpr <$> convertColumnProjectionName i BinaryOperator exprA op exprB -> do @@ -1165,27 +1165,102 @@ convertDBUpdate typeF (UpdateDropTable dt) = convertDropTable typeF dt convertInsert :: TypeForRelExprF -> Insert -> ConvertM DatabaseContextExpr convertInsert typeF ins = do - dfExpr <- convertQuery typeF (source ins) - when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") -- check that all columns are mentioned because Project:M36 does not support default columns - case typeF (convertExpr dfExpr) of + rvTarget <- convertTableName (Insert.target ins) + let eRvTargetType = typeF (RelationVariable rvTarget ()) + case eRvTargetType of Left err -> throwSQLE (SQLRelationalError err) - Right rvExprType -> do - let rvExprAttrNames = A.attributeNamesList (attributes rvExprType) - insAttrNames = map convertUnqualifiedColumnName (Insert.targetColumns ins) - rvExprColNameSet = S.map UnqualifiedColumnName (S.fromList rvExprAttrNames) - insAttrColSet = S.fromList (Insert.targetColumns ins) - when (length rvExprAttrNames /= length insAttrNames) $ throwSQLE (ColumnNamesMismatch rvExprColNameSet insAttrColSet) - rvTarget <- convertTableName (Insert.target ins) - -- insert into s(s#,sname,city,status) select * from s; -- we need to reorder attributes to align? - -- rename attributes rexpr via query/values to map to targetCol attrs - let insExpr = if rvExprColNameSet == insAttrColSet then -- if the attributes already align, don't perform any renaming - convertExpr dfExpr - else - Rename (S.fromList (filter rendundantRename (zip rvExprAttrNames insAttrNames))) (convertExpr dfExpr) - rendundantRename (a,b) = a /= b - --traceShowM ("ins"::String, insExpr) - pure $ B.Insert rvTarget insExpr + Right rvTargetType -> do + -- if types do not align due to nullability, then add SQLJust + dfExpr <- convertQuery typeF (source ins) + when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") +-- traceShowM ("before dfExpr"::String, dfExpr) + case typeF (convertExpr dfExpr) of + Left err -> throwSQLE (SQLRelationalError err) + Right rvExprType -> do +-- traceShowM ("after dfExpr"::String, rvExprType) + let rvExprAttrNames = A.attributeNamesList (attributes rvExprType) + insAttrNames = map convertUnqualifiedColumnName (Insert.targetColumns ins) + rvExprColNameSet = S.map UnqualifiedColumnName (S.fromList rvExprAttrNames) + insAttrColSet = S.fromList (Insert.targetColumns ins) + when (length rvExprAttrNames /= length insAttrNames) $ throwSQLE (ColumnNamesMismatch rvExprColNameSet insAttrColSet) + + + -- insert into s(s#,sname,city,status) select * from s; -- we need to reorder attributes to align? + -- rename attributes rexpr via query/values to map to targetCol attrs + let atomTypeForName' attrName type' = + case atomTypeForName attrName type' of + Left err -> throwSQLE (SQLRelationalError err) + Right targetType -> pure targetType + ren a b (Rename names expr) = Rename (S.insert (a,b) names) expr + ren a b e = Rename (S.singleton (a, b)) e + sqlPrefix s = "_sql_" <> s + projHide n = Project (InvertedAttributeNames (S.singleton n)) + -- if one of the types is a nullable version of the other +-- isSQLNullableCombo t1 t2 = isSQLNullableSpecificType t1 t2 || isSQLNullableSpecificType t2 t1 + sqlNullMorpher interName targetName targetType t2 expr + | isSQLNullableSpecificType targetType t2 = -- targetType is nullable version of t2 + Extend (AttributeExtendTupleExpr targetName (ConstructedAtomExpr "SQLJust" [AttributeAtomExpr interName] ())) expr + | otherwise = expr + + let typeMatchRenamer acc (targetAttrName, sourceAttrName) = do + targetType <- atomTypeForName' targetAttrName rvTargetType + insType <- atomTypeForName' sourceAttrName rvExprType + if targetType == insType && targetAttrName == sourceAttrName then --nothing to do + pure acc + else if targetAttrName /= sourceAttrName && + targetType == insType then do + --simple rename +-- traceShowM ("simple rename"::String) + pure $ ren sourceAttrName targetAttrName acc + else if targetAttrName == sourceAttrName && + targetType /= insType && + isSQLNullableSpecificType targetType insType + then do -- we need to extend the expr, but we want to use the targetName, so we have to rename it twice +-- traceShowM ("same name, null conversion"::String) + let intermediateName = sqlPrefix targetAttrName + pure $ ren intermediateName targetAttrName (sqlNullMorpher intermediateName targetAttrName targetType insType (ren sourceAttrName intermediateName acc)) + else if targetAttrName /= sourceAttrName && + targetType /= insType && + isSQLNullableSpecificType targetType insType then do + -- we extend the expr, but don't need an intermediate rename +-- traceShowM ("diff name, null conversion"::String) + pure $ projHide sourceAttrName (Extend (AttributeExtendTupleExpr targetAttrName (ConstructedAtomExpr "SQLJust" [AttributeAtomExpr sourceAttrName] ())) acc) + else if targetAttrName == sourceAttrName && + isSQLNullUnknownType insType && + isNullAtomType targetType then do +-- traceShowM ("same name, unknown null"::String) + case atomTypeFromSQLNull targetType of + Nothing -> do + pure acc + -- replace null of unknown type with typed null + Just atype -> do + pure $ Extend (AttributeExtendTupleExpr targetAttrName (NakedAtomExpr (nullAtom atype Nothing))) (projHide sourceAttrName acc) + else if targetAttrName /= sourceAttrName && + isSQLNullUnknownType insType && + isNullAtomType targetType then do +-- traceShowM ("different name, unknown null"::String, targetAttrName, sourceAttrName, targetType) + case atomTypeFromSQLNull targetType of + Nothing -> do + pure acc + -- replace null of unknown type with typed null + Just _atype -> do + pure $ projHide sourceAttrName $ Extend (AttributeExtendTupleExpr targetAttrName (ConstructedAtomExpr "SQLNull" [] ())) acc + else + pure acc + + insExpr <- foldM typeMatchRenamer (convertExpr dfExpr) (zip insAttrNames rvExprAttrNames) +{- let insExpr = if rvExprColNameSet == insAttrColSet then -- if the attributes already align, don't perform any renaming + convertExpr dfExpr + else + Rename (S.fromList (filter rendundantRename (zip rvExprAttrNames insAttrNames))) (convertExpr dfExpr) + rendundantRename (a,b) = a /= b-} +{- traceShowM ("source ins"::String, source ins) + traceShowM ("source ins converted"::String, convertExpr dfExpr) + traceShowM ("ins converted"::String, insExpr) + traceShowM ("rvTargetType"::String, rvTargetType)-} + + pure $ B.Insert rvTarget insExpr convertDelete :: TypeForRelExprF -> Delete.Delete -> ConvertM DatabaseContextExpr convertDelete typeF del = do diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index cd9b24c3..462da5f3 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -4,6 +4,9 @@ import ProjectM36.SQL.Convert import ProjectM36.SQL.Select import TutorialD.Interpreter.RODatabaseContextOperator import TutorialD.Interpreter.DatabaseContextExpr +import ProjectM36.RelationalExpression +import ProjectM36.StaticOptimizer +import SQL.Interpreter.DBUpdate import SQL.Interpreter.CreateTable import ProjectM36.DataTypes.SQL.Null import ProjectM36.RelationalExpression @@ -11,7 +14,7 @@ import ProjectM36.TransactionGraph import ProjectM36.DateExamples import ProjectM36.DatabaseContext import ProjectM36.NormalizeExpr -import ProjectM36.Client +import ProjectM36.Client hiding (typeConstructorMapping) import ProjectM36.SQLDatabaseContext import ProjectM36.Base import ProjectM36.Relation @@ -27,7 +30,11 @@ main = do tcounts <- runTestTT (TestList tests) if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess where - tests = [testFindColumn, testSelect, testCreateTable] + tests = [testFindColumn, + testSelect, + testCreateTable, + testDBUpdate + ] testFindColumn :: Test @@ -242,9 +249,9 @@ testSelect = TestCase $ do "(s where not (s#=\"S5\"))" ), -- basic projection NULL - ("SELECT NULL", - "((relation{}{tuple{}}:{attr_1:=SQLNull}){attr_1})", - "((true:{attr_1:=SQLNull}){attr_1})" + ("SELECT NULL", -- convert to null of text type by default + "((relation{}{tuple{}}:{attr_1:=SQLNullOfUnknownType}){attr_1})", + "((true:{attr_1:=SQLNullOfUnknownType}){attr_1})" ), -- restriction NULL ("SELECT * FROM s WHERE s# IS NULL", @@ -259,10 +266,10 @@ testSelect = TestCase $ do "(s{city})" ), ("SELECT NULL AND FALSE", - "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNull,False)}){attr_1})", + "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNullOfUnknownType,False)}){attr_1})", "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust False}})"), ("SELECT NULL AND TRUE", - "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNull,True)}){attr_1})", + "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNullOfUnknownType,True)}){attr_1})", "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})") ] gfEnv = GraphRefRelationalExprEnv { @@ -372,7 +379,68 @@ testCreateTable = TestCase $ do print sql assertEqual "create table SQL" tutdAsDFExpr queryAsDFExpr - mapM_ check createTableTests + mapM_ check createTableTests + +testDBUpdate :: Test +testDBUpdate = TestCase $ do + let sqlDBContext = dateExamples { relationVariables = + M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples), + typeConstructorMapping = typeConstructorMapping dateExamples <> nullTypeConstructorMapping + } + (tgraph,transId) <- freshTransactionGraph sqlDBContext + + let updateTests = [ + -- simple insert with no nulls + ("insert into s(city,status) values(\'New York\',15);", + "insert s relation{tuple{attr_1 \"New York\", attr_2 15}} rename {attr_1 as city, attr_2 as status}" + ), + -- simple insert into nullable column with value + ("insert into snull(\"s#\",sname,status,city) values ('S6','Smith',20,'New York');", + "insert snull ((relation{tuple{attr_1 \"S6\", attr_2 \"Smith\", attr_3 20, attr_4 \"New York\"}} rename {attr_1 as s#, attr_2 as sname, attr_3 as status}) : {city:=SQLJust @attr_4}){all but attr_4}" + ), + -- simple insert into nullable column with NULL + ("insert into snull(\"s#\",sname,status,city) values ('S6','Smith',20,NULL);", + "insert snull ((relation{tuple{attr_1 \"S6\", attr_2 \"Smith\", attr_3 20, attr_4 SQLNullOfUnknownType}} rename {attr_1 as s#, attr_2 as sname, attr_3 as status}):{city:=SQLNull}){all but attr_4}" + ), + -- simple update + ("update s set city='New York' where status=20;", + "update s where sql_coalesce_bool(sql_equals(@status,20)) (city:=\"New York\")" + ) + ] + + parseTutd tutd = do + case parse (multipleDatabaseContextExprP <* eof) "test" tutd of + Left err -> assertFailure (errorBundlePretty err) + Right x -> do + pure x + gfEnv = GraphRefRelationalExprEnv { + gre_context = Just sqlDBContext, + gre_graph = tgraph, + gre_extra = mempty } + typeF = + let reEnv = mkRelationalExprEnv sqlDBContext tgraph in + optimizeAndEvalRelationalExpr reEnv +{- let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr) + runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)-} + + check (sql, equivalent_tutd) = do + --parse SQL + query <- case parse (dbUpdateP <* eof) "test" sql of + Left err -> assertFailure (errorBundlePretty err) + Right x -> do + --print ("parsed SQL:"::String, x) + pure x + --parse tutd + tutdAsDFExpr <- parseTutd equivalent_tutd + queryAsDFExpr <- case evalConvertM mempty (convertDBUpdate typeF query) of + Left err -> assertFailure (show err) + Right x -> do + --print ("convert SQL->tutd:"::String, x) + pure x + print sql + assertEqual "db update SQL" tutdAsDFExpr queryAsDFExpr + + mapM_ check updateTests -- assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection) @@ -391,7 +459,6 @@ dateExamplesConnection callback = do commit sessionId conn >>= eitherFail pure (sessionId, conn) - eitherFail :: Either RelationalError a -> IO () eitherFail (Left err) = assertFailure (show err) eitherFail (Right _) = pure () From 3b800bc3677918a958175da24e47cf534acc474d Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 25 May 2024 00:35:57 -0400 Subject: [PATCH 094/170] add support for no-op begin command --- src/bin/SQL/Interpreter.hs | 2 ++ src/bin/SQL/Interpreter/TransactionGraphOperator.hs | 7 +++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs index 4979402e..a4b2cf3a 100644 --- a/src/bin/SQL/Interpreter.hs +++ b/src/bin/SQL/Interpreter.hs @@ -76,6 +76,8 @@ evalSQLInteractive sessionId conn safeFlag interactiveConsole command = eHandler $ C.commit sessionId conn TransactionGraphOp Rollback -> do eHandler $ C.rollback sessionId conn + TransactionGraphOp Begin -> + pure $ DisplayHintWith ("Advisory Warning: BEGIN is redundant as transaction is started automatically.") QuietSuccessResult where eHandler io = do eErr <- io diff --git a/src/bin/SQL/Interpreter/TransactionGraphOperator.hs b/src/bin/SQL/Interpreter/TransactionGraphOperator.hs index fd25cef4..df1de37a 100644 --- a/src/bin/SQL/Interpreter/TransactionGraphOperator.hs +++ b/src/bin/SQL/Interpreter/TransactionGraphOperator.hs @@ -4,11 +4,14 @@ import SQL.Interpreter.Base import Control.Applicative import Data.Functor (($>)) -data TransactionGraphOperator = Commit | Rollback +data TransactionGraphOperator = Begin | Commit | Rollback deriving (Show, Eq) transactionGraphOperatorP :: Parser TransactionGraphOperator -transactionGraphOperatorP = commitP <|> rollbackP +transactionGraphOperatorP = beginP <|> commitP <|> rollbackP + +beginP :: Parser TransactionGraphOperator +beginP = reserved "begin" $> Begin commitP :: Parser TransactionGraphOperator commitP = reserved "commit" $> Commit From f6712a59944fe124047b9a815d3ef8068c78a65b Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 25 May 2024 00:36:04 -0400 Subject: [PATCH 095/170] add test for simple delete --- test/SQL/InterpreterTest.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 462da5f3..47a86384 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -5,11 +5,10 @@ import ProjectM36.SQL.Select import TutorialD.Interpreter.RODatabaseContextOperator import TutorialD.Interpreter.DatabaseContextExpr import ProjectM36.RelationalExpression -import ProjectM36.StaticOptimizer +--import ProjectM36.StaticOptimizer import SQL.Interpreter.DBUpdate import SQL.Interpreter.CreateTable import ProjectM36.DataTypes.SQL.Null -import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph import ProjectM36.DateExamples import ProjectM36.DatabaseContext @@ -405,7 +404,11 @@ testDBUpdate = TestCase $ do -- simple update ("update s set city='New York' where status=20;", "update s where sql_coalesce_bool(sql_equals(@status,20)) (city:=\"New York\")" - ) + ), + --simple delete + ("delete from s where city='New York';", + "delete s where sql_coalesce_bool(sql_equals(@city,\"New York\"))" + ) ] parseTutd tutd = do @@ -417,11 +420,12 @@ testDBUpdate = TestCase $ do gre_context = Just sqlDBContext, gre_graph = tgraph, gre_extra = mempty } - typeF = +{- typeF = let reEnv = mkRelationalExprEnv sqlDBContext tgraph in - optimizeAndEvalRelationalExpr reEnv -{- let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr) - runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)-} + optimizeAndEvalRelationalExpr reEnv-} + typeF expr = do + let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr) + runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) check (sql, equivalent_tutd) = do --parse SQL From 71ca416d4c2015e34dabe321fb005a40e6f5e4cc Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 26 May 2024 18:00:46 -0400 Subject: [PATCH 096/170] add support for multiple SQL statement execution from console --- src/bin/SQL/Interpreter.hs | 25 +++++++++++++++++-------- src/bin/SQL/Interpreter/DBUpdate.hs | 11 +++++------ src/bin/SQL/Interpreter/sqlegacy.hs | 2 +- 3 files changed, 23 insertions(+), 15 deletions(-) diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs index a4b2cf3a..b2b7cf4a 100644 --- a/src/bin/SQL/Interpreter.hs +++ b/src/bin/SQL/Interpreter.hs @@ -22,12 +22,18 @@ data SQLCommand = RODatabaseContextOp Query | -- SELECT ImportBasicExampleOp ImportBasicExampleOperator | -- IMPORT EXAMPLE cjdate TransactionGraphOp TransactionGraphOperator -- COMMIT, ROLLBACK deriving (Show) + +type SQLCommands = [SQLCommand] -parseSQLUserInput :: T.Text -> Either ParserError SQLCommand -parseSQLUserInput = parse ((parseRODatabaseContextOp <* semi) <|> - parseDatabaseContextExprOp <|> - (parseTransactionGraphOp <* semi) <|> - (parseImportBasicExampleOp <* semi)) "" +parseSQLUserInput :: T.Text -> Either ParserError SQLCommands +parseSQLUserInput = parse (some semiCommand <* eof) "" + +semiCommand :: Parser SQLCommand +semiCommand = (parseRODatabaseContextOp <|> + parseDatabaseContextExprOp <|> + parseTransactionGraphOp <|> + parseImportBasicExampleOp) <* semi + parseRODatabaseContextOp :: Parser SQLCommand parseRODatabaseContextOp = RODatabaseContextOp <$> queryP @@ -41,8 +47,11 @@ parseTransactionGraphOp = TransactionGraphOp <$> transactionGraphOperatorP parseDatabaseContextExprOp :: Parser SQLCommand parseDatabaseContextExprOp = DBUpdateOp <$> dbUpdatesP -evalSQLInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> SQLCommand -> IO ConsoleResult -evalSQLInteractive sessionId conn safeFlag interactiveConsole command = +evalSQLInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> [SQLCommand] -> IO [ConsoleResult] +evalSQLInteractive sessionId conn _safeFlag _interactiveConsole commands = + mapM evalOneCommand commands + where + evalOneCommand command = case command of RODatabaseContextOp query -> do --get relvars to build conversion context @@ -57,7 +66,7 @@ evalSQLInteractive sessionId conn safeFlag interactiveConsole command = Right df -> pure $ DisplayHintWith ("[Equivalent TutorialD] " <> hint) (DisplayDataFrameResult df) ImportBasicExampleOp (ImportBasicExampleOperator exampleName) -> do if exampleName == "cjdate" then - evalSQLInteractive sessionId conn safeFlag interactiveConsole (DatabaseContextExprOp (databaseContextAsDatabaseContextExpr dateExamples)) + evalOneCommand (DatabaseContextExprOp (databaseContextAsDatabaseContextExpr dateExamples)) else pure (DisplayErrorResult ("No such example: " <> exampleName)) DatabaseContextExprOp dbcExpr -> do diff --git a/src/bin/SQL/Interpreter/DBUpdate.hs b/src/bin/SQL/Interpreter/DBUpdate.hs index 1a562d57..be85d89f 100644 --- a/src/bin/SQL/Interpreter/DBUpdate.hs +++ b/src/bin/SQL/Interpreter/DBUpdate.hs @@ -6,16 +6,15 @@ import SQL.Interpreter.Insert import SQL.Interpreter.Delete import SQL.Interpreter.CreateTable import SQL.Interpreter.DropTable -import SQL.Interpreter.Base import Text.Megaparsec dbUpdatesP :: Parser [DBUpdate] dbUpdatesP = some dbUpdateP dbUpdateP :: Parser DBUpdate -dbUpdateP = (UpdateUpdate <$> updateP <* semi) <|> - (UpdateInsert <$> insertP <* semi) <|> - (UpdateDelete <$> deleteP <* semi) <|> - (UpdateCreateTable <$> createTableP <* semi) <|> - (UpdateDropTable <$> dropTableP <* semi) +dbUpdateP = (UpdateUpdate <$> updateP) <|> + (UpdateInsert <$> insertP) <|> + (UpdateDelete <$> deleteP) <|> + (UpdateCreateTable <$> createTableP) <|> + (UpdateDropTable <$> dropTableP) diff --git a/src/bin/SQL/Interpreter/sqlegacy.hs b/src/bin/SQL/Interpreter/sqlegacy.hs index 6edf0a13..0edc0b5e 100644 --- a/src/bin/SQL/Interpreter/sqlegacy.hs +++ b/src/bin/SQL/Interpreter/sqlegacy.hs @@ -38,7 +38,7 @@ sqlReprLoop sessionId conn mPromptLength userInput = do Right parsed -> catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do evald <- evalSQLInteractive sessionId conn UnsafeEvaluation True parsed - displayResult evald) + mapM_ displayResult evald) (\_ -> displayResult (DisplayErrorResult "Request timed out.")) From dca74d2da42138136af466f90c6ce8b0667358de Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 26 May 2024 18:01:02 -0400 Subject: [PATCH 097/170] remove dead code add more basic tests --- src/lib/ProjectM36/SQL/Convert.hs | 67 +------------------------------ test/SQL/InterpreterTest.hs | 26 +++++++++++- 2 files changed, 25 insertions(+), 68 deletions(-) diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 777304a2..deed5e4e 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -36,13 +36,10 @@ import Data.Foldable (foldl') import Data.Bifunctor (bimap) --import qualified Data.HashSet as HS -import Debug.Trace +--import Debug.Trace {- TODO -* remove commented out code -* remove unused functions from failed experiments -* remove traceShow* * enable duplicate rows by adding uuid column -} @@ -158,8 +155,6 @@ withSubSelect m = do (TableContext postSub) <- get put state -- diff the state to get just the items that were added --- traceShowM ("keys orig"::String, M.keys orig) --- traceShowM ("keys postSub"::String, M.keys postSub) let tableDiffFolder acc (tAlias, (RelationVariable _rv (), _ , colAliasRemapper)) = do let convertColAliases :: ColumnAliasRemapper -> (AttributeName, (AttributeName, S.Set ColumnName)) -> ColumnAliasRenameMap -> ColumnAliasRenameMap convertColAliases origColAlRemapper (attrName, (attrAlias,_)) acc' = @@ -213,8 +208,6 @@ insertTable tAlias expr rtype = do noteColumnMention :: Maybe TableAlias -> ColumnName -> Maybe ColumnAlias -> ConvertM ColumnAlias noteColumnMention mTblAlias colName mColAlias = do -- find the relevant table for the key to the right table --- traceShowM ("noteColumnMention"::String, mTblAlias, colName) --- traceStateM tc@(TableContext tcontext) <- get -- check if we already have a mention mapping let lookupWithTableAlias (TableAlias tAlias) colAttr = do @@ -229,12 +222,9 @@ noteColumnMention mTblAlias colName mColAlias = do insertColAlias (maybe tPrefixColAttr unColumnAlias mColAlias) Just (_, _, colAlRemapper) -> do -- table alias already known, check for column alias --- traceShowM ("noteColumnMention before attr"::String, colAlRemapper) case attributeNameForAttributeAlias colAttr colAlRemapper of Left _ -> do -- col alias missing, so add it- figure out if it needs a table prefix - --traceShowM ("findNotedColumn' in noteColumnMention"::String, colAlias) - --traceStateM let sqlColAlias = maybe colAttr unColumnAlias mColAlias case findNotedColumn' (ColumnName [colAttr]) tc of Left _ -> -- no match, so table prefix not required @@ -244,8 +234,6 @@ noteColumnMention mTblAlias colName mColAlias = do Right [_] -> -- we have a match, so we need the table prefix insertColAlias (maybe tPrefixColAttr unColumnAlias mColAlias) Right (_:_) -> throwSQLE (AmbiguousColumnResolutionError colName) - --traceShowM ("findNotedColumn' in noteColumnMentionB"::String, colAlias') - --pure colAlias' Right attrName -> -- we know the alias already, so return it pure (ColumnAlias attrName) @@ -296,7 +284,6 @@ findColumn targetCol = -- | non ConvertM version of findColumn findColumn' :: ColumnName -> TableContext -> [TableAlias] findColumn' targetCol (TableContext tMap) = do --- traceShowM ("findColumn'", targetCol, tMap) M.foldrWithKey folder [] tMap where folder tAlias@(TableAlias tat) (_rvExpr, rtype, _) acc = @@ -337,7 +324,6 @@ findNotedColumn' colName _ = Left $ UnexpectedColumnNameError colName attributeNameForAttributeAlias :: AttributeAlias -> ColumnAliasRemapper -> Either SQLError AttributeName attributeNameForAttributeAlias al remapper = do --- traceShowM ("attributeNameForAttributeAlias"::String, al, remapper) foldr folder (Left (ColumnAliasResolutionError (ColumnAlias al))) (M.toList remapper) where folder (_attrName, (attrAlias, _)) acc = @@ -373,7 +359,6 @@ attributeNameForColumnName colName = do ColumnName [attr] -> pure $ ColumnAlias attr ColumnName [_tname,attr] -> pure $ ColumnAlias attr ColumnName{} -> throwSQLE $ ColumnResolutionError colName --- traceShowM ("attributeNameForColumnName' colAlias"::String, colAttr, colAliases, colAlias) case M.lookup colAttr colAliases of Just (alias,_) -> pure alias -- we found it, so it's valid Nothing -> @@ -384,12 +369,9 @@ attributeNameForColumnName colName = do Right _ -> pure colAttr Left (AmbiguousColumnResolutionError{}) -> do --we have a conflict, so insert a new column alias and return it --- traceShowM ("attributeNameForColumnName"::String, colName) (ColumnAlias al) <- noteColumnMention (Just tKey) (ColumnName [tAlias,colAttr]) Nothing - --traceShowM ("attributeNameForColumnName' noteColumnMention"::String, colAttr, al) pure al Left err -> throwSQLE err - --pure (T.concat [tAlias, ".", colAttr]) else case colName of ColumnName [_, col] | col `A.isAttributeNameContained` rvattrs -> @@ -463,7 +445,6 @@ convertSelect typeF sel = do (dfExpr, _colRemap) <- case tableExpr sel of Nothing -> pure (baseDFExpr, mempty) Just tExpr -> convertTableExpr typeF' tExpr --- traceShowM ("table aliases", tAliasMap) let explicitWithF = if null wExprs then id else With wExprs (groupByExprs, havingExpr) = case tableExpr sel of Nothing -> ([],Nothing) @@ -478,7 +459,6 @@ convertSelect typeF sel = do finalRelExpr = explicitWithF (withF (projF (convertExpr dfExpr))) -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes -- apply rename reduction- this could be applied by the static query optimizer, but we do it here to simplify the tests so that they aren't polluted with redundant renames - traceShowM ("final expr"::String, finalRelExpr) pure (dfExpr { convertExpr = finalRelExpr }) @@ -505,7 +485,6 @@ convertSubSelect typeF sel = do Nothing -> pure (baseDFExpr, mempty) Just tExpr -> convertTableExpr typeF' tExpr when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") --- traceShowM ("convertSubSelect"::String, colMap) let explicitWithF = if null wExprs then id else With wExprs -- convert projection using table alias map to resolve column names projF <- convertProjection typeF' (projectionClause sel) [] Nothing -- the projection can only project on attributes from the subselect table expression @@ -515,12 +494,8 @@ convertSubSelect typeF sel = do [] -> id _ -> With withAssocs -- add disambiguation renaming --- traceShowM ("subselect tExpr"::String, convertExpr dfExpr) pure (explicitWithF . withF . projF, convertExpr dfExpr) -{- let renamesF = Rename (S.fromList (map renamer (M.toList colRenames))) - renamer ((TableAlias tAlias, realAttr), ColumnAlias newAttr) = - (realAttr, newAttr)-} let renamedExpr = foldr renamerFolder tExpr (M.toList colRenames) renamerFolder ((TableAlias tAlias, oldAttrName), ColumnAlias newAttrName)= pushDownAttributeRename (S.singleton (oldAttrName, newAttrName)) (RelationVariable tAlias ()) @@ -568,13 +543,8 @@ convertSelectItem typeF acc (c,selItem) = convertProjection :: TypeForRelExprF -> [SelectItem] -> [GroupByExpr] -> Maybe HavingExpr -> ConvertM (RelationalExpr -> RelationalExpr) convertProjection typeF selItems groupBys havingExpr = do --- traceShowM ("convertProjection", selItems, groupBys) groupInfo <- convertGroupBy typeF groupBys havingExpr selItems --- traceShowM ("convertProjection grouping"::String, groupInfo) --- attrName' (Just (ColumnAlias nam)) _ = nam --- attrName' Nothing c = "attr_" <> T.pack (show c) task <- foldM (convertSelectItem typeF) emptyTask (zip [1::Int ..] selItems) --- traceShowM ("convertProjection task"::String, task) -- SQL supports only one grouping at a time, but multiple aggregations, so we create the group as attribute "_sql_aggregate" and the aggregations as fold projections on it fGroup <- if not (null (nonAggregates groupInfo)) || (null (nonAggregates groupInfo) && not (null (aggregates groupInfo))) @@ -613,7 +583,6 @@ convertProjection typeF selItems groupBys havingExpr = do -- apply extensions let fExtended = foldr (\ext acc -> Extend ext . acc) id (taskExtenders task) -- process SQL aggregates by replacing projections --- let fAggregates -- apply rename renamesSet <- foldM (\acc (qProjName, ColumnAlias newName) -> do oldName <- convertColumnProjectionName qProjName @@ -679,8 +648,6 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do pure (NotPredicate TruePredicate) BinaryOperator (Identifier colName) (OperatorName ["="]) exprMatch -> do --we don't know here if this results in a boolean expression, so we pass it down attrName <- attributeNameForColumnName colName --- traceShowM ("convertWhereClause eq"::String, colName, attrName) --- traceStateM expr' <- convertScalarExpr typeF exprMatch pure (AtomExprPredicate (coalesceBoolF (FunctionAtomExpr "sql_equals" [AttributeAtomExpr attrName, expr'] ()))) BinaryOperator exprA op exprB -> do @@ -690,7 +657,6 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do pure (AtomExprPredicate (coalesceBoolF (f [a,b]))) PostfixOperator expr (OperatorName ops) -> do expr' <- convertScalarExpr typeF expr --- traceShowM ("convertWhereClause"::String, expr') let isnull = AtomExprPredicate (coalesceBoolF (FunctionAtomExpr "sql_isnull" [expr'] ())) case ops of ["is", "null"] -> @@ -937,7 +903,6 @@ joinTableRef typeF rvA (_c,tref) = do (tKey, rvB) <- convertTableRef typeF jtref --rvA and rvB now reference potentially aliased relation variables (needs with clause to execute), but this is useful for making attributes rv-prefixed --- traceShowM ("converted", rvA, rvB, tAliases) --extract all table aliases to create a remapping for SQL names discovered in the sexpr withExpr <- With <$> tableAliasesAsWithNameAssocs @@ -954,8 +919,6 @@ joinTableRef typeF rvA (_c,tref) = do -- rvPrefixB <- rvPrefix rvB exprA <- prefixRenamer (TableAlias rvNameA) rvA (S.toList attrsA) exprB <- prefixRenamer tKey (RelationVariable rvNameB ()) (S.toList attrsB) --- traceShowM ("exprA", exprA) --- traceShowM ("exprB", exprB) -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition joinRe <- convertScalarExpr typeF joinExpr --' why are we renaming here- can't we call attributenameforcolumnname in the scalarexpr conversion??? --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name = @@ -1174,11 +1137,9 @@ convertInsert typeF ins = do -- if types do not align due to nullability, then add SQLJust dfExpr <- convertQuery typeF (source ins) when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery") --- traceShowM ("before dfExpr"::String, dfExpr) case typeF (convertExpr dfExpr) of Left err -> throwSQLE (SQLRelationalError err) Right rvExprType -> do --- traceShowM ("after dfExpr"::String, rvExprType) let rvExprAttrNames = A.attributeNamesList (attributes rvExprType) insAttrNames = map convertUnqualifiedColumnName (Insert.targetColumns ins) rvExprColNameSet = S.map UnqualifiedColumnName (S.fromList rvExprAttrNames) @@ -1211,25 +1172,21 @@ convertInsert typeF ins = do else if targetAttrName /= sourceAttrName && targetType == insType then do --simple rename --- traceShowM ("simple rename"::String) pure $ ren sourceAttrName targetAttrName acc else if targetAttrName == sourceAttrName && targetType /= insType && isSQLNullableSpecificType targetType insType then do -- we need to extend the expr, but we want to use the targetName, so we have to rename it twice --- traceShowM ("same name, null conversion"::String) let intermediateName = sqlPrefix targetAttrName pure $ ren intermediateName targetAttrName (sqlNullMorpher intermediateName targetAttrName targetType insType (ren sourceAttrName intermediateName acc)) else if targetAttrName /= sourceAttrName && targetType /= insType && isSQLNullableSpecificType targetType insType then do -- we extend the expr, but don't need an intermediate rename --- traceShowM ("diff name, null conversion"::String) pure $ projHide sourceAttrName (Extend (AttributeExtendTupleExpr targetAttrName (ConstructedAtomExpr "SQLJust" [AttributeAtomExpr sourceAttrName] ())) acc) else if targetAttrName == sourceAttrName && isSQLNullUnknownType insType && isNullAtomType targetType then do --- traceShowM ("same name, unknown null"::String) case atomTypeFromSQLNull targetType of Nothing -> do pure acc @@ -1239,7 +1196,6 @@ convertInsert typeF ins = do else if targetAttrName /= sourceAttrName && isSQLNullUnknownType insType && isNullAtomType targetType then do --- traceShowM ("different name, unknown null"::String, targetAttrName, sourceAttrName, targetType) case atomTypeFromSQLNull targetType of Nothing -> do pure acc @@ -1516,27 +1472,6 @@ replaceProjScalarExpr r orig = where recr = replaceProjScalarExpr r --- convert group by info into extend tasks -{- -convertGroupByInfo :: GroupByInfo -> SelectItemsConvertTask -> SelectItemsConvertTask -convertGroupByInfo ginfo task = - task { taskExtenders = taskExtenders task <> gbyExtenders, - taskProjections = taskProjections tasks <> gbyProjections } - where - grouper = AttributeExtendTupleExpr "_sql_aggregate" - (RelationAtomExpr - ( - gbyExtenders = grouper : map mkAggregateExtender (aggregates groupInfo) - mkAggregateExtender sexpr = - replaceProjScalarExpr (\expr -> - case expr of - FunctionApplication fname [Identifier colName] - | fname == "sql_max" -> - FunctionApplication fname [ -- cannot make RelationalExpr here and we want to make a RelationValuedAttribute-based expression - gbyProjections = -- map mkAggregateProjection (aggregates groupInfo) --- mkAggregateProjection expr = - -} - -- find SQL aggregate functions and replace then with folds on attribute "_sql_aggregate" processSQLAggregateFunctions :: AtomExpr -> AtomExpr processSQLAggregateFunctions expr = diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 47a86384..603d14d3 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -8,6 +8,7 @@ import ProjectM36.RelationalExpression --import ProjectM36.StaticOptimizer import SQL.Interpreter.DBUpdate import SQL.Interpreter.CreateTable +import SQL.Interpreter.Base (semi) import ProjectM36.DataTypes.SQL.Null import ProjectM36.TransactionGraph import ProjectM36.DateExamples @@ -264,12 +265,19 @@ testSelect = TestCase $ do "(((s where not sql_coalesce_bool(sql_isnull(@city)))){city})", "(s{city})" ), + -- some basic NULL logic ("SELECT NULL AND FALSE", "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNullOfUnknownType,False)}){attr_1})", "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust False}})"), ("SELECT NULL AND TRUE", "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNullOfUnknownType,True)}){attr_1})", - "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})") + "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})"), + ("SELECT NULL OR FALSE", + "((relation{}{tuple{}}:{attr_1:=sql_or(SQLNullOfUnknownType,False)}){attr_1})", + "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})"), + ("SELECT NULL OR TRUE", + "((relation{}{tuple{}}:{attr_1:=sql_or(SQLNullOfUnknownType,True)}){attr_1})", + "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust True}})") ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just sqlDBContext, @@ -429,7 +437,7 @@ testDBUpdate = TestCase $ do check (sql, equivalent_tutd) = do --parse SQL - query <- case parse (dbUpdateP <* eof) "test" sql of + query <- case parse (dbUpdateP <* semi <* eof) "test" sql of Left err -> assertFailure (errorBundlePretty err) Right x -> do --print ("parsed SQL:"::String, x) @@ -445,6 +453,20 @@ testDBUpdate = TestCase $ do assertEqual "db update SQL" tutdAsDFExpr queryAsDFExpr mapM_ check updateTests + +{- +testTransactionGraphOps :: Test +testTransactionGraphOps = TestCase $ do + let sqlDBContext = dateExamples { relationVariables = + M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples), + typeConstructorMapping = typeConstructorMapping dateExamples <> nullTypeConstructorMapping + } + (tgraph,transId) <- freshTransactionGraph sqlDBContext + + let graphTests = [("begin;create table x(a integer not null);commit;", + "(x==relation{a integer})") + ] +-} -- assertEqual "SELECT * FROM test" (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test") dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection) From 2b2b2d712b6eea8ef61e85e54ad5bde64db32f3c Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 26 May 2024 18:01:27 -0400 Subject: [PATCH 098/170] add haskell-actions github CI setup step --- .github/workflows/ci.yaml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 117b8b56..cbf67f14 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -43,7 +43,7 @@ jobs: env: STACK_YAML: stack.${{ matrix.ghc }}.yaml steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - name: Cache uses: actions/cache@v3 with: @@ -56,6 +56,12 @@ jobs: run: rm -rf ~/.stack/setup-exe-cache # - name: HLint # run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . + - name: Setup Stack + uses: haskell-actions/setup@v2 + with: + enable-stack: true + ghc-version: ${{ matrix.ghc }} + cabal-version: 3.10.2.1 - name: Build run: stack build --ghc-options -O2 --local-bin-path out --copy-bins - name: Test From c2cefc46810ab4c4fb247e1b22785b4e92de8ffe Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 26 May 2024 19:15:00 -0400 Subject: [PATCH 099/170] more CI gimmicks --- .github/workflows/ci.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index cbf67f14..bbc01d6a 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -6,7 +6,7 @@ jobs: dockerimage: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixos-unstable @@ -35,8 +35,8 @@ jobs: matrix: os: [ubuntu-latest] ghc: - - ghc9.2 - - ghc9.4 + - ghc9.2.8 + - ghc9.4.7 include: - os: macos-latest ghc: ghc9.2 From 680a170acb011e507ff77e5ab7f918ef8109cdff Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 26 May 2024 23:07:00 -0400 Subject: [PATCH 100/170] experiment with "haskell-ci github" --- .github/workflows/ci.yaml | 6 +- .github/workflows/haskell-ci.yml | 196 +++++++++++++++++++++++++++++++ 2 files changed, 197 insertions(+), 5 deletions(-) create mode 100644 .github/workflows/haskell-ci.yml diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index bbc01d6a..12135804 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -57,11 +57,7 @@ jobs: # - name: HLint # run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . - name: Setup Stack - uses: haskell-actions/setup@v2 - with: - enable-stack: true - ghc-version: ${{ matrix.ghc }} - cabal-version: 3.10.2.1 + run: curl -sSL https://get.haskellstack.org/ | sh - name: Build run: stack build --ghc-options -O2 --local-bin-path out --copy-bins - name: Test diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml new file mode 100644 index 00000000..89e917d1 --- /dev/null +++ b/.github/workflows/haskell-ci.yml @@ -0,0 +1,196 @@ +# This GitHub workflow config has been generated by a script via +# +# haskell-ci 'github' 'project-m36.cabal' +# +# To regenerate the script (for example after adjusting tested-with) run +# +# haskell-ci regenerate +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +# version: 0.19.20240514 +# +# REGENDATA ("0.19.20240514",["github","project-m36.cabal"]) +# +name: Haskell-CI +on: + - push + - pull_request +jobs: + linux: + name: Haskell-CI - Linux - ${{ matrix.compiler }} + runs-on: ubuntu-20.04 + timeout-minutes: + 60 + container: + image: buildpack-deps:jammy + continue-on-error: ${{ matrix.allow-failure }} + strategy: + matrix: + include: + - compiler: ghc-9.4.8 + compilerKind: ghc + compilerVersion: 9.4.8 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.2.8 + compilerKind: ghc + compilerVersion: 9.2.8 + setup-method: ghcup + allow-failure: false + fail-fast: false + steps: + - name: apt + run: | + apt-get update + apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: Set PATH and environment variables + run: | + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + echo "LANG=C.UTF-8" >> "$GITHUB_ENV" + echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" + echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" + HCDIR=/opt/$HCKIND/$HCVER + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') + echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" + echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" + echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" + echo "HEADHACKAGE=false" >> "$GITHUB_ENV" + echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" + echo "GHCJSARITH=0" >> "$GITHUB_ENV" + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: env + run: | + env + - name: write cabal config + run: | + mkdir -p $CABAL_DIR + cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz + echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - + xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan + rm -f cabal-plan.xz + chmod a+x $HOME/.cabal/bin/cabal-plan + cabal-plan --version + - name: checkout + uses: actions/checkout@v4 + with: + path: source + - name: initial cabal.project for sdist + run: | + touch cabal.project + echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project + cat cabal.project + - name: sdist + run: | + mkdir -p sdist + $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist + - name: unpack + run: | + mkdir -p unpacked + find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; + - name: generate cabal.project + run: | + PKGDIR_project_m36="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/project-m36-[0-9.]*')" + echo "PKGDIR_project_m36=${PKGDIR_project_m36}" >> "$GITHUB_ENV" + rm -f cabal.project cabal.project.local + touch cabal.project + touch cabal.project.local + echo "packages: ${PKGDIR_project_m36}" >> cabal.project + echo "package project-m36" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project + cat >> cabal.project <> cabal.project.local + cat cabal.project + cat cabal.project.local + - name: dump install plan + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all + cabal-plan + - name: restore cache + uses: actions/cache/restore@v4 + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store + restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- + - name: install dependencies + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all + - name: build w/o tests + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all + - name: build + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: tests + run: | + $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct + - name: cabal check + run: | + cd ${PKGDIR_project_m36} || false + ${CABAL} -vnormal check + - name: haddock + run: | + $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all + - name: unconstrained build + run: | + rm -f cabal.project.local + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all + - name: save cache + uses: actions/cache/save@v4 + if: always() + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store From 29aebdbfd33557dd6a41922664fe4cb186652f5f Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 26 May 2024 23:38:20 -0400 Subject: [PATCH 101/170] more ci fiddling --- .github/workflows/haskell-ci.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 89e917d1..ca51f6e3 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -149,6 +149,7 @@ jobs: echo "packages: ${PKGDIR_project_m36}" >> cabal.project echo "package project-m36" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project + echo "allow-newer: fast-builder:base" >> cabal.project cat >> cabal.project <> cabal.project.local From bcc2fe6eece0440dfd8d4326605643b662404079 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 26 May 2024 23:40:22 -0400 Subject: [PATCH 102/170] fiddle with stack location --- .github/workflows/ci.yaml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 12135804..25b920d1 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -56,14 +56,14 @@ jobs: run: rm -rf ~/.stack/setup-exe-cache # - name: HLint # run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . - - name: Setup Stack - run: curl -sSL https://get.haskellstack.org/ | sh +# - name: Setup Stack +# run: curl -sSL https://get.haskellstack.org/ | sh - name: Build - run: stack build --ghc-options -O2 --local-bin-path out --copy-bins + run: /usr/local/bin/stack build --ghc-options -O2 --local-bin-path out --copy-bins - name: Test - run: stack test --stack-yaml=${{ env.STACK_YAML }} + run: /usr/local/bin/stack test --stack-yaml=${{ env.STACK_YAML }} - name: Haddock - run: stack --no-install-ghc --system-ghc --no-haddock-deps haddock + run: /usr/local/bin/stack --no-install-ghc --system-ghc --no-haddock-deps haddock - uses: actions/upload-artifact@v3 with: name: project-m36-${{ matrix.os }}-${{ matrix.ghc }} From bd88282bcf3b5a7a2c79649c603c9f2a63cf875c Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 26 May 2024 23:42:05 -0400 Subject: [PATCH 103/170] restore cabal build --- .github/workflows/ci.yaml | 2 +- .github/workflows/haskell-ci.yml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 25b920d1..bb42de57 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -1,4 +1,4 @@ -name: "CI" +name: "Stack" on: pull_request: push: diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index ca51f6e3..145f9dc2 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -12,7 +12,7 @@ # # REGENDATA ("0.19.20240514",["github","project-m36.cabal"]) # -name: Haskell-CI +name: "Cabal" on: - push - pull_request @@ -149,7 +149,7 @@ jobs: echo "packages: ${PKGDIR_project_m36}" >> cabal.project echo "package project-m36" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project - echo "allow-newer: fast-builder:base" >> cabal.project + echo "allow-newer: fast-builder:base" >> cabal.project cat >> cabal.project <> cabal.project.local From 2b389398a50174672daaef97ef68bf58227a8620 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 26 May 2024 23:45:16 -0400 Subject: [PATCH 104/170] switch back to simplified GHC versions --- .github/workflows/ci.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index bb42de57..ce455a4b 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -35,8 +35,8 @@ jobs: matrix: os: [ubuntu-latest] ghc: - - ghc9.2.8 - - ghc9.4.7 + - ghc9.2 + - ghc9.4 include: - os: macos-latest ghc: ghc9.2 From d007ecc5c279b1444276879733a87c047defe4a5 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 00:46:59 -0400 Subject: [PATCH 105/170] refactor stack ci --- .github/workflows/ci.yaml | 34 ++++++++++++++++++++-------------- project-m36.cabal | 1 + 2 files changed, 21 insertions(+), 14 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index ce455a4b..ba8a749f 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -34,37 +34,43 @@ jobs: strategy: matrix: os: [ubuntu-latest] - ghc: - - ghc9.2 - - ghc9.4 + ghc_version: + - 9.2 + - 9.4 include: - os: macos-latest - ghc: ghc9.2 + ghc_version: 9.2 env: - STACK_YAML: stack.${{ matrix.ghc }}.yaml + STACK_YAML: stack.ghc${{ matrix.ghc_version }}.yaml + PATH: $PATH:~/.ghcup/bin steps: - uses: actions/checkout@v4 - name: Cache uses: actions/cache@v3 with: path: ~/.stack - key: ${{ runner.os }}-build-stack-${{ matrix.ghc }}-${{ hashFiles(env.STACK_YAML) }}-${{ hashFiles('**/*.cabal') }} + key: ${{ runner.os }}-build-stack-ghc${{ matrix.ghc_version }}-${{ hashFiles(env.STACK_YAML) }}-${{ hashFiles('**/*.cabal') }} restore-keys: | - ${{ runner.os }}-build-stack-${{ matrix.ghc }}-${{ hashFiles(env.STACK_YAML) }} - ${{ runner.os }}-build-stack-${{ matrix.ghc }} + ${{ runner.os }}-build-stack-ghc${{ matrix.ghc_version }}-${{ hashFiles(env.STACK_YAML) }} + ${{ runner.os }}-build-stack-ghc${{ matrix.ghc_version }} - name: Fix macOS cache bug run: rm -rf ~/.stack/setup-exe-cache # - name: HLint # run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . -# - name: Setup Stack -# run: curl -sSL https://get.haskellstack.org/ | sh + - name: Install ghcup dependencies + - run: apt-get install build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 + - name: Setup GHCUp + run: | + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + ghcup install ghc ${{ ghc_version }} + ghcup install stack - name: Build - run: /usr/local/bin/stack build --ghc-options -O2 --local-bin-path out --copy-bins + run: stack build --ghc-options -O2 --local-bin-path out --copy-bins - name: Test - run: /usr/local/bin/stack test --stack-yaml=${{ env.STACK_YAML }} + run: stack test --stack-yaml=${{ env.STACK_YAML }} - name: Haddock - run: /usr/local/bin/stack --no-install-ghc --system-ghc --no-haddock-deps haddock + run: stack --no-install-ghc --system-ghc --no-haddock-deps haddock - uses: actions/upload-artifact@v3 with: - name: project-m36-${{ matrix.os }}-${{ matrix.ghc }} + name: project-m36-${{ matrix.os }}-ghc${{ matrix.ghc_version }} path: out/ diff --git a/project-m36.cabal b/project-m36.cabal index 3cb96455..355331a5 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -13,6 +13,7 @@ Maintainer: agentm@themactionfaction.com Synopsis: Relational Algebra Engine Description: A relational algebra engine which can be used to persist and query Haskell data types. Extra-Source-Files: Changelog.markdown README.markdown +tested-with: GHC ==9.2.8 || ==9.4.8 Source-Repository head Type: git From f8f794a378168981377f5315183cce79ca26f7d2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 01:00:58 -0400 Subject: [PATCH 106/170] fix tab in ci yaml --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index ba8a749f..fa4b15e9 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -63,7 +63,7 @@ jobs: run: | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh ghcup install ghc ${{ ghc_version }} - ghcup install stack + ghcup install stack - name: Build run: stack build --ghc-options -O2 --local-bin-path out --copy-bins - name: Test From 52e3f8c24c8efd8d4dcf943103a0eaaac614f753 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 01:04:52 -0400 Subject: [PATCH 107/170] ghcup dependencies in ci --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index fa4b15e9..0454ce23 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -58,7 +58,7 @@ jobs: # - name: HLint # run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . - name: Install ghcup dependencies - - run: apt-get install build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 + run: apt-get install build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 - name: Setup GHCUp run: | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh From f9f644ead040a7db633993c2a595de3326d98d6c Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 01:12:09 -0400 Subject: [PATCH 108/170] fix ghcup setup step --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 0454ce23..8b10fc12 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -62,7 +62,7 @@ jobs: - name: Setup GHCUp run: | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh - ghcup install ghc ${{ ghc_version }} + ghcup install ghc ${{ matrix.ghc_version }} ghcup install stack - name: Build run: stack build --ghc-options -O2 --local-bin-path out --copy-bins From 6415c5be6619ee04c242b22eefb4eb1d43d64385 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 01:18:55 -0400 Subject: [PATCH 109/170] fix path for ghcup --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 8b10fc12..e7248da6 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -42,7 +42,6 @@ jobs: ghc_version: 9.2 env: STACK_YAML: stack.ghc${{ matrix.ghc_version }}.yaml - PATH: $PATH:~/.ghcup/bin steps: - uses: actions/checkout@v4 - name: Cache @@ -64,6 +63,7 @@ jobs: curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh ghcup install ghc ${{ matrix.ghc_version }} ghcup install stack + echo "~/.ghcup/bin" >> ${GITHUB_PATH} - name: Build run: stack build --ghc-options -O2 --local-bin-path out --copy-bins - name: Test From f86ea456b455c3716e1b44b10549137b12a19552 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 01:21:10 -0400 Subject: [PATCH 110/170] fix sudo for apt-get --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index e7248da6..458076c8 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -57,7 +57,7 @@ jobs: # - name: HLint # run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . - name: Install ghcup dependencies - run: apt-get install build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 + run: sudo apt-get install build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 - name: Setup GHCUp run: | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh From 7cc917fa25909bedd9cf9be0e13a0dcb94d3e8c2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 01:28:46 -0400 Subject: [PATCH 111/170] run apt only on Linux --- .github/workflows/ci.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 458076c8..536312ee 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -58,6 +58,7 @@ jobs: # run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . - name: Install ghcup dependencies run: sudo apt-get install build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 + if: runner.os == 'Linux' - name: Setup GHCUp run: | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh From 33bee3c79c7f4f675ca4d8f3712d76c977708a33 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 01:39:58 -0400 Subject: [PATCH 112/170] fix benchmark --- src/bin/benchmark/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/bin/benchmark/Server.hs b/src/bin/benchmark/Server.hs index e7b93057..8552e1c0 100644 --- a/src/bin/benchmark/Server.hs +++ b/src/bin/benchmark/Server.hs @@ -23,7 +23,7 @@ handleError eErr = case eErr of --test local connection speeds of inserts, updates, and deletes to look for space leaks, etc. main :: IO () main = do - conn <- handleIOError $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback []) + conn <- handleIOError $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext) sess <- handleIOError $ createSessionAtHead conn "master" _ <- handleIOError $ executeDatabaseContextExpr sess conn (toDefineExpr (Proxy :: Proxy User) "user") From 140d4bebdc0e3c634bfe5baa98194db29fa1856d Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 01:40:12 -0400 Subject: [PATCH 113/170] fix ghcup path --- .github/workflows/ci.yaml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 536312ee..ebfe821b 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -62,9 +62,10 @@ jobs: - name: Setup GHCUp run: | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + echo "~/.ghcup/bin" >> $GITHUB_PATH ghcup install ghc ${{ matrix.ghc_version }} ghcup install stack - echo "~/.ghcup/bin" >> ${GITHUB_PATH} + - name: Build run: stack build --ghc-options -O2 --local-bin-path out --copy-bins - name: Test From 0490b78844615010e8972d1fb8c4a65d297d85a7 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 11:00:10 -0400 Subject: [PATCH 114/170] fix bitrotted benchmarks --- project-m36.cabal | 1 + src/bin/benchmark/Basic.hs | 24 ++++++++++-------------- src/bin/benchmark/OnDiskClient.hs | 2 +- 3 files changed, 12 insertions(+), 15 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index 355331a5..53b1c816 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -479,6 +479,7 @@ Test-Suite test-prettyprinter benchmark bench import: commontest + build-depends: criterion type: exitcode-stdio-1.0 main-is: benchmark/Relation.hs diff --git a/src/bin/benchmark/Basic.hs b/src/bin/benchmark/Basic.hs index cda728bf..13380b90 100644 --- a/src/bin/benchmark/Basic.hs +++ b/src/bin/benchmark/Basic.hs @@ -5,13 +5,11 @@ import ProjectM36.Relation import ProjectM36.Persist import ProjectM36.RelationalExpression import ProjectM36.Error -import ProjectM36.Transaction.Persist +import ProjectM36.TransactionGraph import qualified Data.Text as T import qualified Data.Vector as V -import Control.Monad.Trans.Reader import qualified ProjectM36.DatabaseContext as DBC import qualified Data.Set as S -import Data.Monoid import System.IO.Temp import System.FilePath import System.Directory @@ -38,23 +36,23 @@ createRelation' :: Int -> Int -> Relation createRelation' x y = validate (createRelation x y) restrictRelationToOneTuple :: Int -> Relation -> Relation -restrictRelationToOneTuple match rel = validate (runReader (evalRelationalExpr restriction) exprState) +restrictRelationToOneTuple match rel = validate (runRelationalExprM basicREEnv (evalRelationalExpr restriction)) where - exprState = mkRelationalExprState DBC.empty restriction = Restrict predicateMatch (ExistingRelation rel) predicateMatch = AttributeEqualityPredicate "a0" (NakedAtomExpr (IntAtom match)) restrictRelationToHalfRelation :: Int -> Relation -> Relation -restrictRelationToHalfRelation cutoff rel = validate (runReader (evalRelationalExpr restriction) exprState) +restrictRelationToHalfRelation cutoff rel = validate (runRelationalExprM basicREEnv (evalRelationalExpr restriction)) where - exprState = mkRelationalExprState DBC.basicDatabaseContext restriction = Restrict predicateMatch (ExistingRelation rel) predicateMatch = AtomExprPredicate (FunctionAtomExpr "lte" [AttributeAtomExpr "a0", NakedAtomExpr (IntAtom cutoff)] ()) +basicREEnv :: RelationalExprEnv +basicREEnv = mkRelationalExprEnv DBC.basicDatabaseContext emptyTransactionGraph + projectRelationToAttributes :: AttributeNames -> Relation -> Relation -projectRelationToAttributes attrNames rel = validate (runReader (evalRelationalExpr projection) exprState) +projectRelationToAttributes attrNames rel = validate (runRelationalExprM basicREEnv (evalRelationalExpr projection)) where - exprState = mkRelationalExprState DBC.empty projection = Project attrNames (ExistingRelation rel) unionRelations :: Relation -> Relation -> Relation @@ -64,9 +62,7 @@ joinRelations :: Relation -> Relation -> Relation joinRelations relA relB = validate (join relA relB) groupRelation :: AttributeNames -> Relation -> Relation -groupRelation attrNames rel = validate (runReader (evalRelationalExpr (Group attrNames "x" (ExistingRelation rel))) exprState) - where - exprState = mkRelationalExprState DBC.empty +groupRelation attrNames rel = validate (runRelationalExprM basicREEnv (evalRelationalExpr (Group attrNames "x" (ExistingRelation rel)))) bigRelAttrNames :: Int -> Int -> AttributeNames bigRelAttrNames start end = AttributeNames (S.fromList (map (\i -> "a" <> T.pack (show i)) [start .. end])) @@ -101,6 +97,6 @@ main = do group100 = bench "group 10x100" (nf (groupRelation (bigRelAttrNames 1 9)) bigrel100) writeRel tmpDir = bgroup "write" [writeRel10000 tmpDir] - writeRel10000 tmpDir = bench "write 10x1000" $ nfIO (writeRelVar FsyncDiskSync tmpDir ("x", bigrel10000)) + writeRel10000 tmpDir = bench "write 10x1000" $ nfIO (writeSerialiseSync FsyncDiskSync tmpDir ("x"::String, bigrel10000)) - \ No newline at end of file + diff --git a/src/bin/benchmark/OnDiskClient.hs b/src/bin/benchmark/OnDiskClient.hs index 6ece7131..d8e0ab91 100644 --- a/src/bin/benchmark/OnDiskClient.hs +++ b/src/bin/benchmark/OnDiskClient.hs @@ -38,7 +38,7 @@ main :: IO () main = do let parser = info (parseOptions <**> helper) (fullDesc <> progDesc "Read or write data for heap profiling.") opts <- execParser parser - let connInfo = InProcessConnectionInfo (MinimalPersistence (datadir opts)) emptyNotificationCallback [] + let connInfo = InProcessConnectionInfo (MinimalPersistence (datadir opts)) emptyNotificationCallback [] basicDatabaseContext eCheck v = do x <- v case x of From 798466a33f89a0419a6d84ab16e8bc2d8d4b11ef Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 11:06:55 -0400 Subject: [PATCH 115/170] more ghcup wrangling --- .github/workflows/ci.yaml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index ebfe821b..9ea365df 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -62,7 +62,8 @@ jobs: - name: Setup GHCUp run: | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh - echo "~/.ghcup/bin" >> $GITHUB_PATH + echo "$HOME/.ghcup/bin" >> $GITHUB_PATH + ls -al $HOME/.ghcup/bin ghcup install ghc ${{ matrix.ghc_version }} ghcup install stack From 521fb767b75b4e38e3baf38c21079b06f9fe8793 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 11:19:18 -0400 Subject: [PATCH 116/170] fix tab indentation in yaml ci --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 9ea365df..058803a7 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -63,7 +63,7 @@ jobs: run: | curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh echo "$HOME/.ghcup/bin" >> $GITHUB_PATH - ls -al $HOME/.ghcup/bin + ls -al $HOME/.ghcup/bin ghcup install ghc ${{ matrix.ghc_version }} ghcup install stack From 8154b8989e894f3c4f269d772ca26679e6f6eb90 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 11:25:34 -0400 Subject: [PATCH 117/170] figure out why ghcup is not in github path --- .github/workflows/ci.yaml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 058803a7..065897d2 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -64,9 +64,11 @@ jobs: curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh echo "$HOME/.ghcup/bin" >> $GITHUB_PATH ls -al $HOME/.ghcup/bin - ghcup install ghc ${{ matrix.ghc_version }} - ghcup install stack - + echo $GITHUB_PATH + - name: Install GHC + run: ghcup install ghc ${{ matrix.ghc_version }} + - name: Install Stack + run: ghcup install stack - name: Build run: stack build --ghc-options -O2 --local-bin-path out --copy-bins - name: Test From 4c5aba50a8b5071effbf87ad73f24708648bb540 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 11:28:46 -0400 Subject: [PATCH 118/170] fix tab in ci yaml --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 065897d2..94828ffe 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -64,7 +64,7 @@ jobs: curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh echo "$HOME/.ghcup/bin" >> $GITHUB_PATH ls -al $HOME/.ghcup/bin - echo $GITHUB_PATH + echo $GITHUB_PATH - name: Install GHC run: ghcup install ghc ${{ matrix.ghc_version }} - name: Install Stack From 205bc57dbe78d6830aa9ccbf2978726322d52c4a Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 19:45:30 -0400 Subject: [PATCH 119/170] add tutd scripts to cabal file to include in sdist for haskell ci --- project-m36.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project-m36.cabal b/project-m36.cabal index 53b1c816..40b05bad 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -12,7 +12,7 @@ Category: Relational Algebra Maintainer: agentm@themactionfaction.com Synopsis: Relational Algebra Engine Description: A relational algebra engine which can be used to persist and query Haskell data types. -Extra-Source-Files: Changelog.markdown README.markdown +Extra-Source-Files: Changelog.markdown README.markdown scripts/DateExamples.tutd scripts/emp.tutd scripts/multiline.tutd tested-with: GHC ==9.2.8 || ==9.4.8 Source-Repository head From 902c495973eb44f19a3c718f870843e5ea52514d Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 20:12:02 -0400 Subject: [PATCH 120/170] remove incomplete emp.tutd from extra source files --- project-m36.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project-m36.cabal b/project-m36.cabal index 40b05bad..47ada30b 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -12,7 +12,7 @@ Category: Relational Algebra Maintainer: agentm@themactionfaction.com Synopsis: Relational Algebra Engine Description: A relational algebra engine which can be used to persist and query Haskell data types. -Extra-Source-Files: Changelog.markdown README.markdown scripts/DateExamples.tutd scripts/emp.tutd scripts/multiline.tutd +Extra-Source-Files: Changelog.markdown README.markdown scripts/DateExamples.tutd scripts/multiline.tutd tested-with: GHC ==9.2.8 || ==9.4.8 Source-Repository head From 23141dc657e0997faa6b0c68a41f935bba9a6a65 Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 27 May 2024 20:15:38 -0400 Subject: [PATCH 121/170] update away from deprecated github actions --- .github/workflows/ci.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 94828ffe..e381a16b 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -10,7 +10,7 @@ jobs: - uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixos-unstable - - uses: cachix/cachix-action@v12 + - uses: cachix/cachix-action@v15 with: name: project-m36 signingKey: "${{ secrets.CACHIX_SIGNING_KEY }}" @@ -45,7 +45,7 @@ jobs: steps: - uses: actions/checkout@v4 - name: Cache - uses: actions/cache@v3 + uses: actions/cache@v4 with: path: ~/.stack key: ${{ runner.os }}-build-stack-ghc${{ matrix.ghc_version }}-${{ hashFiles(env.STACK_YAML) }}-${{ hashFiles('**/*.cabal') }} @@ -75,7 +75,7 @@ jobs: run: stack test --stack-yaml=${{ env.STACK_YAML }} - name: Haddock run: stack --no-install-ghc --system-ghc --no-haddock-deps haddock - - uses: actions/upload-artifact@v3 + - uses: actions/upload-artifact@v4 with: name: project-m36-${{ matrix.os }}-ghc${{ matrix.ghc_version }} path: out/ From 21d50ca09202a23ea2511ed6b784efa434c0a40f Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 30 May 2024 09:10:37 -0400 Subject: [PATCH 122/170] switch ghcup ci step to use noninteractive option --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index e381a16b..ad41733f 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -61,7 +61,7 @@ jobs: if: runner.os == 'Linux' - name: Setup GHCUp run: | - curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh + curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh echo "$HOME/.ghcup/bin" >> $GITHUB_PATH ls -al $HOME/.ghcup/bin echo $GITHUB_PATH From 7ab83ed18e0f2402cd451bdfb3163331f2b2a70b Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 30 May 2024 09:10:47 -0400 Subject: [PATCH 123/170] fix hlint --- src/bin/SQL/Interpreter.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs index b2b7cf4a..8e07bbb5 100644 --- a/src/bin/SQL/Interpreter.hs +++ b/src/bin/SQL/Interpreter.hs @@ -48,8 +48,8 @@ parseDatabaseContextExprOp :: Parser SQLCommand parseDatabaseContextExprOp = DBUpdateOp <$> dbUpdatesP evalSQLInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> [SQLCommand] -> IO [ConsoleResult] -evalSQLInteractive sessionId conn _safeFlag _interactiveConsole commands = - mapM evalOneCommand commands +evalSQLInteractive sessionId conn _safeFlag _interactiveConsole = + mapM evalOneCommand where evalOneCommand command = case command of @@ -86,7 +86,7 @@ evalSQLInteractive sessionId conn _safeFlag _interactiveConsole commands = TransactionGraphOp Rollback -> do eHandler $ C.rollback sessionId conn TransactionGraphOp Begin -> - pure $ DisplayHintWith ("Advisory Warning: BEGIN is redundant as transaction is started automatically.") QuietSuccessResult + pure $ DisplayHintWith "Advisory Warning: BEGIN is redundant as transaction is started automatically." QuietSuccessResult where eHandler io = do eErr <- io From a445c68ac76d27751d6bfd36ca5b944604597852 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 30 May 2024 09:11:01 -0400 Subject: [PATCH 124/170] add abs and mean functions --- src/lib/ProjectM36/AtomFunctions/Primitive.hs | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/lib/ProjectM36/AtomFunctions/Primitive.hs b/src/lib/ProjectM36/AtomFunctions/Primitive.hs index ef5699a2..1d37476b 100644 --- a/src/lib/ProjectM36/AtomFunctions/Primitive.hs +++ b/src/lib/ProjectM36/AtomFunctions/Primitive.hs @@ -20,6 +20,13 @@ primitiveAtomFunctions = HS.fromList [ funcBody = body (\case IntegerAtom i1:IntegerAtom i2:_ -> pure (IntegerAtom (i1 + i2)) _ -> Left AtomFunctionTypeMismatchError)}, + Function { funcName = "abs", + funcType = [IntegerAtomType, IntegerAtomType], + funcBody = body (\case + IntegerAtom i:_ -> pure $ IntegerAtom (abs i) + _ -> Left AtomFunctionTypeMismatchError + ) + }, Function { funcName = "id", funcType = [TypeVariableType "a", TypeVariableType "a"], funcBody = body (\case @@ -42,6 +49,10 @@ primitiveAtomFunctions = HS.fromList [ funcType = foldAtomFuncType IntegerAtomType IntegerAtomType, funcBody = body $ relationAtomFunc relationMin }, + Function { funcName = "mean", + funcType = foldAtomFuncType IntegerAtomType IntegerAtomType, + funcBody = body $ relationAtomFunc relationMean + }, Function { funcName = "eq", funcType = [TypeVariableType "a", TypeVariableType "a", BoolAtomType], funcBody = body $ \case @@ -148,6 +159,15 @@ relationMin relIn = case oneTuple relIn of where newVal tupIn = castInteger (tupleAtoms tupIn V.! 0) +relationMean :: Relation -> Either AtomFunctionError Atom +relationMean relIn = case oneTuple relIn of + Nothing -> Left AtomFunctionEmptyRelationError + Just _oneTup -> do + let (sum'', count') = relFold (\tupIn (sum', count) -> (sum' + newVal tupIn, count + 1)) (0, 0) relIn + newVal tupIn = castInteger (tupleAtoms tupIn V.! 0) + pure (IntegerAtom (sum'' `div` count')) + + castInt :: Atom -> Int castInt (IntAtom i) = i castInt _ = error "attempted to cast non-IntAtom to Int" From bf3c51a8f1da1f8c330f43fc83b8afff21f49a2e Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 30 May 2024 12:38:33 -0400 Subject: [PATCH 125/170] fix test tutoriald failure due to adding more functions --- test/TutorialD/InterpreterTest.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/TutorialD/InterpreterTest.hs b/test/TutorialD/InterpreterTest.hs index 1cb61944..48d594d6 100644 --- a/test/TutorialD/InterpreterTest.hs +++ b/test/TutorialD/InterpreterTest.hs @@ -805,7 +805,7 @@ testDDLHash = TestCase $ do Right hash2 <- getDDLHash sessionId dbconn assertBool "add relvar" (hash1 /= hash2) -- the test should break if the hash is calculated differently - assertEqual "static hash check" "2agn0YDfvffgBe23XHZEqLni+JOWi3ex0P3vxRcYKk0=" (B64.encode (_unSecureHash hash1)) + assertEqual "static hash check" "ds0uvEvV8CvivyYyxJ75S0CeAnNzKAAH5AdOv74+ydM=" (B64.encode (_unSecureHash hash1)) -- remove an rv executeTutorialD sessionId dbconn "undefine x" Right hash3 <- getDDLHash sessionId dbconn From 3785bec768b73691d7089f978bfeddbf451b178a Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 1 Jun 2024 18:38:00 -0400 Subject: [PATCH 126/170] fix ordering of gt,lt in SQL parser --- src/bin/SQL/Interpreter/Select.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index 1e04288d..f2bebddd 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -165,7 +165,7 @@ scalarExprOp = E.Postfix betweenSuffixP --binarySymbolsN ["not", "like"] ], - map binarySymbolN ["<",">",">=","<=","!=","<>","="], + map binarySymbolN [">=","<=","!=","<>","=", "<",">"], [postfixKeywords ["is","null"], postfixKeywords ["is","not","null"]], {- [binarySymbolsN ["is", "distinct", "from"], binarySymbolsN ["is", "not", "distinct", "from"]],-} From f9ad204bd2adad3477091428ac81241caae67b47 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 1 Jun 2024 18:38:17 -0400 Subject: [PATCH 127/170] add support for Text lt,gt,etc. --- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 49 ++++++++++++++++-------- 1 file changed, 33 insertions(+), 16 deletions(-) diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index 4b9a31ff..d846e3c7 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -9,6 +9,7 @@ import ProjectM36.AtomFunction import ProjectM36.Tuple import ProjectM36.Relation import Data.Maybe (isJust) +import Data.Text (Text) -- analogous but not equivalent to a Maybe type due to how NULLs interact with every other value @@ -93,26 +94,41 @@ nullAtomFunctions = HS.fromList [ funcType = [TypeVariableType "a", BoolAtomType], funcBody = FunctionBuiltInBody sqlIsNull } - ] <> sqlBooleanIntegerFunctions + ] <> sqlCompareFunctions -sqlBooleanIntegerFunctions :: HS.HashSet AtomFunction -sqlBooleanIntegerFunctions = HS.fromList $ - map (\(sql_func, op) -> - Function { - funcName = sql_func, - funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType], - funcBody = FunctionBuiltInBody (sqlIntegerBinaryBoolean op) - }) ops +sqlCompareFunctions :: HS.HashSet AtomFunction +sqlCompareFunctions = HS.fromList $ + map mkFunc ops where - sqlIntegerBinaryBoolean op = - sqlIntegerBinaryFunction BoolAtomType (\a b -> BoolAtom (a `op` b)) - ops = [("sql_gt", (>)), - ("sql_lt", (<)), - ("sql_gte", (>=)), - ("sql_lte", (<=)) + mkFunc (sql_func, opi, opt) = + Function { + funcName = sql_func, + funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType], + funcBody = FunctionBuiltInBody (sqlCompareFunc (opi, opt)) + } + boolNull = nullAtom BoolAtomType Nothing + sqlCompareFunc :: (Integer -> Integer -> Bool, Text -> Text -> Bool) -> [Atom] -> Either AtomFunctionError Atom + sqlCompareFunc (opi, opt) [atomA, atomB] = + case (maybeFromAtom atomA, maybeFromAtom atomB) of + (Nothing, _) -> pure boolNull + (_, Nothing) -> pure boolNull + (Just (IntegerAtom a), Just (IntegerAtom b)) -> pure $ nullAtom BoolAtomType (Just (BoolAtom (opi a b))) + (Just (TextAtom a), Just (TextAtom b)) -> pure (nullAtom BoolAtomType (Just (BoolAtom (opt a b)))) + _ -> Left AtomFunctionTypeMismatchError + sqlCompareFunc _ _ = Left AtomFunctionTypeMismatchError + ops :: [(FunctionName, + Integer -> Integer -> Bool, + Text -> Text -> Bool)] + ops = [("sql_gt", (>), (>)), + ("sql_lt", (<), (<)), + ("sql_gte", (>=), (>=)), + ("sql_lte", (<=), (<=)) ] - + +maybeFromAtom :: Atom -> Maybe Atom +maybeFromAtom atom | isNull atom = Nothing +maybeFromAtom atom = Just atom coalesceBool :: [Atom] -> Either AtomFunctionError Atom coalesceBool [arg] = case sqlBool arg of @@ -273,6 +289,7 @@ sqlNullableIntegerToMaybe :: Atom -> Maybe Integer sqlNullableIntegerToMaybe (IntegerAtom i) = Just i sqlNullableIntegerToMaybe (ConstructedAtom "SQLJust" aType [IntegerAtom i]) | aType == nullAtomType IntegerAtomType = Just i sqlNullableIntegerToMaybe (ConstructedAtom "SQLNull" aType []) | aType == nullAtomType IntegerAtomType = Nothing +sqlNullableIntegerToMaybe (ConstructedAtom "SQLNullOfUnknownType" aType []) | aType == nullAtomType IntegerAtomType = Nothing sqlNullableIntegerToMaybe _ = Nothing -- check that types check out- Int and SQLNullable Int are OK, Int and SQLNullable Text are not OK From 2a1d2ba30c5212cd94f03e29cfe29712283921b4 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 5 Jun 2024 00:53:48 -0400 Subject: [PATCH 128/170] support empty select statement fix partial parsing of operators in scalar exprs --- src/bin/SQL/Interpreter/Select.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index f2bebddd..ec470e3f 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -64,7 +64,7 @@ selectP = do selectItemListP :: Parser [SelectItem] -selectItemListP = sepBy1 selectItemP comma +selectItemListP = sepBy selectItemP comma selectItemP :: Parser SelectItem selectItemP = (,) <$> scalarExprP <*> optional (reserved "as" *> columnAliasP) @@ -194,9 +194,9 @@ qualifiedOperatorP sym = where segmentsP :: [Text] -> Parser [Text] segmentsP segments = case segments of - [] -> error "empty operator" + [] -> fail "empty operator" [seg] -> do - final <- qualifiedNameSegment seg + final <- try (qualifiedNameSegment seg <* notFollowedBy alphaNumChar) pure [final] (seg:remainder) -> do first <- qualifiedNameSegment seg From 6dfa711bf2507dda32062506e6c985275813ee23 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 5 Jun 2024 00:54:04 -0400 Subject: [PATCH 129/170] fix printing of atom expression arguments --- src/bin/TutorialD/Printer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index 1b2967b0..552b90ea 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -60,7 +60,7 @@ prettyAtomExpr atomExpr = _ -> pretty atomExpr prettyAtomExprsAsArguments :: [AtomExpr] -> Doc ann -prettyAtomExprsAsArguments = align . parensList . map addAt +prettyAtomExprsAsArguments = {-align .-} parensList . map addAt where addAt (atomExpr :: AtomExpr) = case atomExpr of AttributeAtomExpr attrName -> "@" <> prettyAttributeName attrName From 235cb95ecb0cb62a9e152a98e0ab1a45bccb184b Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 5 Jun 2024 00:54:16 -0400 Subject: [PATCH 130/170] add finalexpr optional debug printing --- src/lib/ProjectM36/SQL/Convert.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index deed5e4e..5f506730 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -459,6 +459,7 @@ convertSelect typeF sel = do finalRelExpr = explicitWithF (withF (projF (convertExpr dfExpr))) -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes -- apply rename reduction- this could be applied by the static query optimizer, but we do it here to simplify the tests so that they aren't polluted with redundant renames +-- traceShowM ("finalExpr"::String, finalRelExpr) pure (dfExpr { convertExpr = finalRelExpr }) From 271bdbabb468b5140ec9f5c6767a00e0f9e4a11a Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 6 Jun 2024 02:25:56 -0400 Subject: [PATCH 131/170] add "Why SQLegacy?" documentation --- docs/why_sqlegacy.markdown | 773 +++++++++++++++++++++++++++++++++++++ 1 file changed, 773 insertions(+) create mode 100644 docs/why_sqlegacy.markdown diff --git a/docs/why_sqlegacy.markdown b/docs/why_sqlegacy.markdown new file mode 100644 index 00000000..d5e61f02 --- /dev/null +++ b/docs/why_sqlegacy.markdown @@ -0,0 +1,773 @@ +# Why SQLegacy? + +### Prelude + +Project:M36 is a complete implementation of the relational algebra. However, the most popular database interaction language, SQL, diverges significantly from the relational algebra for historical reasons. This document examines these divergencies and explains the motivation for Project:M36 to implement SQL but also offer an alternative: TutorialD. + +## Introduction + +The benefits of sticking to the mathematics of the relational algebra are many: + +* any possible data modeling the world's state can be normalized and retained +* any possible query against such data can be represented and processed +* the data is independent of any specific format +* queries are independent of any execution means + +### On the Value of Having Options + +The advantage of having no specific behavior proscribed by the math of the relational algebra enables database management systems to choose from an ever-increasing swath of technologies, especially as hardware and algorithms develop, but without affecting queries and data manipulation. + +Conversely, we *can* lock ourselves into specific implementations and data arrangements and formats such as with key-value databases. The cost, however, is that we can only make specific queries on a specific data arrangement (keys) and the algorithms are often tuned for specific hardware. As a business reliant on a key-value database evolves, the brittleness of the database becomes apparent, made especially obvious if the database cannot reasonably answer queries that the developers and database did not anticipate. Oops! + +The solution is to rely on an algebra designed for complete data management which naturally implies permanent and unchanging APIs to access the data. Math does not change. The hardware and software limitations practitioners face can and should be pushed down and away from the top-level database access use-cases. + +While SQL, as a declarative language, does better on the "options" axis than key-value databases, it still fails the mathematical cohesiveness test. We will examine these failings in this document. + +### Project:M36+TutorialD vs. SQL + +Project:M36 is a ground-up reimaginging of what a relational algebra engine could be. It was born out of the frustrations of dealing with SQL so it aims to avoid the pitfalls of SQL. However, any serious, production DBMS nowadays supports SQL out of necessity- Project:M36 is no exception. Deliberate care was taken to ensure that SQL is bolted on top of a relational algebra core. To achieve this, a database interaction language apart from SQL was required: TutorialD. TutorialD has been developed over decades by database expert C.J. Date, an author who also recognized the irreconciable flaws of SQL. + +Project:M36's SQL shim over a relational algebra core makes SQL flaws more obvious through comparative implementation. Unfortunately, it is not even true that SQL supports a strict subset of the relational algebra. + +Fortunately, Project:M36 implements TutorialD: an interactive console language which unlocks the full power of the relational algebra. + +## SQL Deviations from the Relational Algebra + +The following is non-exhaustive list of SQL deviations from the relational algebra. For the purposes of demonstration, PostgreSQL is used a reference SQL implementation. Wikipedia can be used as the [definition of the relational algebra](https://en.wikipedia.org/wiki/Relational_algebra), if necessary. + +### Duplicate Rows vs. Set of Tuples + +The relational algebra defines a relation as a set of attributes (header) with a set of tuples (body) mapping values to the header's attributes. SQL intentionally fails to implement this constraint. + +```SQL +create table employee as select * from (values (1,'Steve'),(1,'Steve')) as x(id,name); +SELECT 2 + +table employee; + id | name +----+------- + 1 | Steve + 1 | Steve +``` + +If we consider each row as a proposition modeling the state of the world, what does it mean to say truth twice? It's not only meaningless, it actively harmful as developers have to contend with the possibility of receiving duplicate rows in query results. Thus SQL queries are peppered with `DISTINCT` and `GROUP BY` even though the natural language query assumes that the result would be naturally distinct: + +``` +select distinct * from employee; + id | name +----+------- + 1 | Steve +``` + +Still, the underlying source of data (the table) is ambiguous: do we have two different Steves with the same employee id or one Steve mentioned twice? It's not clear and ambiguity in modeling the world is undesired, stated mildly. + +One could pose the counterargument that the database designer is responsible for eliminating such ambiguity, but then why does the database enable ambiguity at all? + +Could we force SQL to enforce sets of tuples? Yes, but only on base tables using constraints. Queries can still generate arbitrary duplicates. + +The relational algebra demands that a relation contain a set of tuples, but is there a penalty for diverging? Yes. Consider the following query: + +```SQL +SELECT x.a FROM x JOIN (SELECT DISTINCT a FROM y) as y2 ON x.a = y2.a; +``` + +A simple query planner has two options: it can execute the join first or the projection on `x.a` first. However, SQL allows column `a` in either table to contain duplicates and only the JOINed table is deduplicated. So, the execution engine *must* run the deduplicating join execution step first! (See "[23.2.3 Ordering of Relational Operators](https://dl.acm.org/doi/pdf/10.5555/77708.C1065772)") Pushing projections to run first can often reduce the amount of data being pushed between execution steps- that cannot happen here. Thus, "allowing" duplicate rows in relations reduces the relational expression optimization space. + +### Inconsistent Aggregations vs. Folds + +One of the benefits of math is its context-independent consistency. Developers rely on this fact, even unknowingly. For example, no developer expects a `sine` function to return different values depending on its calling function. Consistent function operation enables a developer to reason about his program and avoid bugs. + +SQL aggregations are unfortunately not consistent. + +``` +create table agg as select * from (values (1),(1),(2),(NULL)) as x(a); +table agg; + a +--- + 1 + 1 + 2 + +(4 rows) + +``` + +How many rows are there in the table? + +``` +SELECT COUNT(*) FROM agg; + count +------- + 4 +(1 row) +``` + +Ok, but how many non-null values of `a` are there? + +``` +SELECT count(a) from agg; + count +------- + 3 +(1 row) +``` + +Oh, ok. But how many distinct values of `a` are there? + +``` +SELECT count(distinct a) from agg; + count +------- + 2 +(1 row) +``` + +Wait. Is NULL not considered a distinct value? How many distinct values including NULL are there? + +``` +SELECT COUNT(*) FROM (SELECT DISTINCT a FROM agg) as x; + count +------- + 3 +(1 row) +``` + +So, NULL is DISTINCT in a projection but ignored by `COUNT(a)`? If your head is spinning, you are not alone. The mix of aggregations ignoring NULL and handling duplicates is difficult to reason about. In the relational algebra, none of these issues arise- ternary logic (logic involving NULL- discussed later) is not required and aggregations are completely predictable. + +``` +TutorialD (master/main): agg:=relation{tuple{a 1},tuple{a 1},tuple{a 2}} +TutorialD (master/main): :showexpr agg +┌──────────┐ +│a::Integer│ +├──────────┤ +│2 │ +│1 │ +└──────────┘ +TutorialD (master/main): :showexpr agg group({a} as g):{c:=count(@g)} +┌──────────┬────────────────────────┐ +│c::Integer│g::relation {a::Integer}│ +├──────────┼────────────────────────┤ +│2 │┌──────────┐ │ +│ ││a::Integer│ │ +│ │├──────────┤ │ +│ ││1 │ │ +│ ││2 │ │ +│ │└──────────┘ │ +└──────────┴────────────────────────┘ +``` +Yes, that is a relation as a value. Nested relations (discussed below) are a critical part of the relational algebra, but not supported in SQL. + +Writing predictable and correct queries doesn't need to be difficult. We just need to follow the math. + +### Lossy Results in SQL Aggregates vs. Nested Relations + +The power and promise of relational algebra is to be able to pose any query we could possible desire on the data. The algebra does this by providing composable building blocks (functions) to process and alter the data in a set of relations. However, SQL falls flat here, too. Consider the following query: + +Show me the employees' average salary alongside their salaries. + +Oops, in SQL, we have to fake this using non-standard array aggregations or by writing two queries. + +``` +table employee; + name | salary +-------+-------- + Steve | 10000 + Bob | 15000 + Maria | 17000 +(3 rows) +select avg(salary) from employee; + avg +-------------------- + 14000.000000000000 +(1 row) +select avg(salary),array_agg(ROW(name,salary)) from employee; + avg | array_agg +--------------------+------------------------------------------------- + 14000.000000000000 | {"(Steve,10000)","(Bob,15000)","(Maria,17000)"} +(1 row) +``` +Of course, with arrays, we have now left the relational algebra- suddenly the set of tuples has become a list of tuples; relational algebra operators cannot run on arrays, etc. + +The relational algebra has this solved: + +``` +TutorialD (master/main): employee:=relation{tuple{name "Steve", salary 10000},tuple{name "Bob",salary 15000},tuple{name "Maria",salary 17000}} +TutorialD (master/main): :showexpr employee{salary} group({salary} as g):{avg:=mean(@g)} +┌────────────┬─────────────────────────────┐ +│avg::Integer│g::relation {salary::Integer}│ +├────────────┼─────────────────────────────┤ +│14000 │┌───────────────┐ │ +│ ││salary::Integer│ │ +│ │├───────────────┤ │ +│ ││10000 │ │ +│ ││15000 │ │ +│ ││17000 │ │ +│ │└───────────────┘ │ +└────────────┴─────────────────────────────┘ +``` + +By leveraging nested relations, we can see both the mean and its constituent salaries. + +### Unnamed Columns + +SQL supports expressions like this: + +``` +SELECT 1+3; + ?column? +---------- + 4 +(1 row) +``` + +Clearly, no table is queried here, so a column-less table with one row is assumed (into which we can place our result). PostgreSQL is generous enough to generate a name "?column?" on our behalf, but how are clients supposed to access it? In fact, the column name is completely arbitrary: + +``` +test=# select 1+3 union select 4 as name; + ?column? +---------- + 4 +(1 row) +``` + +What about if we have two unnamed columns? + +``` +select 1+3,2+3; + ?column? | ?column? +----------+---------- + 4 | 5 +(1 row) +``` + +The relational algebra states simply that the names of the columns/attributes must exist and be unique. Otherwise, how can we be expected to execute further queries on these columns? + +``` +select ?? + 10 from (select 1+3) as x; +select a+10, b+11 from (select 1+3,2+3) as x(a,b); + ?column? | ?column? +----------+---------- + 14 | 16 +(1 row) + +``` + +In this case, SQL forces us to name the columns to be able to use them. Why shouldn't it simply do that up-front? + +### Duplicate Column Names + +SQL allows column names to be repeated: + +``` +SELECY 1 AS a, 2 AS a; + a | a +---+--- + 1 | 2 +(1 row) + +``` + +even in a subquery: + +``` +select * from (select 1 as a, 2 as a) as x; + a | a +---+--- + 1 | 2 + +``` + +but then we're punished if we want to use the name: + +``` +select a from (select 1 as a, 2 as a) as x; +ERROR: column reference "a" is ambiguous +LINE 1: select a from (select 1 as a, 2 as a) as x; +``` + +That means duplicate column names are footguns if we try to use the names. What is the point of this? + +The relational algebra defines the header of a relation to be a set of attributes. Attributes cannot have duplicates, so there is no ambiguity possible. + +### Projection vs. Extension + +SQL allows us to define expressions like this: + +`select a+4 as a from x;` + +whereby each value of `a` in table `x` is added to four. The resultant column is also called `a`. However, this construction conflates two relational operators: extension and projection. + +Projection is used to trim columns from a table or other relational expression. Here is pure projection in SQL: + +`select a from x;` + +Extension is used to derive new values from values in a relation. Here is pure extension in SQL: + +`select *,a+4 as new_val from x;` + +By conflating the two relational operators, SQL creates ambiguity. For example, does the following SQL apply `abs()` before or after `DISTINCT`? + +`select distinct abs(a) from (values (1),(-1)) as x(a);` + +Because abs(a) is both projection and extension, it is not obvious that the `abs()` extension is applied before projection. When is the `DISTINCT` applied (it turns out it's applied last)? SQL certainly does not make any of this clear. + +TutorialD makes projection and extension obvious and unambiguous: + +``` +TutorialD (master/main): :showexpr (relation{tuple{a 1,b 2},tuple{a -1,b 3}}:{a2:=abs(@a)}){a2} +┌───────────┐ +│a2::Integer│ +├───────────┤ +│1 │ +└───────────┘ +``` + +First, the extension with `abs()` occurs, then we project on the new attribute's name. Done. + +### NULL: A Billion Dollar Boondoggle + +NULLs are absolutely not a component of the relational algebra. After all, the relational algebra does not require any specific sort of types. However, NULLs are so pervasive in SQL, they are worth mentioning in terms of how NULLs negatively affect query writing, query optimization, and query execution. + +First and foremost, the presence of NULLs make it difficult for an SQL developer to feel confident about his queries. Consider: + +``` +SELECT AVG(age) FROM citizen; +``` + +If there is a NULL age, that does not affect the average. (AVG() ignores NULLs.) However, this "rule" only applies to aggregate functions. but aggregate functions are indistinguishable from standard, value-altering functions: + +``` +SELECT ABS(age) FROM citizen; +``` + +One cannot know by looking at the syntax that one query creates one row as an answer and the other creates as many rows as there are in `citizen`. In TutorialD, this is unambiguous. Aggregate function applications can only be applied to nested relations: + +``` +TutorialD (master/main): :importexample cjdate +TutorialD (master/main): :showexpr s +┌──────────┬────────┬───────────┬───────────────┐ +│city::Text│s#::Text│sname::Text│status::Integer│ +├──────────┼────────┼───────────┼───────────────┤ +│"Paris" │"S2" │"Jones" │10 │ +│"Paris" │"S3" │"Blake" │30 │ +│"London" │"S4" │"Clark" │20 │ +│"London" │"S1" │"Smith" │20 │ +│"Athens" │"S5" │"Adams" │30 │ +└──────────┴────────┴───────────┴───────────────┘ +TutorialD (master/main): :showexpr s:{m:=mean(@status)} +ERR: AtomFunctionTypeError "mean" 1 (RelationAtomType (attributesFromList [(Attribute "_" IntegerAtomType)])) IntegerAtomType +``` + +which indicates a type mismatch error- an aggregate function can only operate on relations containing integers, not integers. + +When used correctly, the aggregate function operates on a nested relation. +``` +TutorialD (master/main): :showexpr (s{status} group({status} as s)):{m:=mean(@s)} +┌──────────┬─────────────────────────────┐ +│m::Integer│s::relation {status::Integer}│ +├──────────┼─────────────────────────────┤ +│20 │┌───────────────┐ │ +│ ││status::Integer│ │ +│ │├───────────────┤ │ +│ ││20 │ │ +│ ││30 │ │ +│ ││10 │ │ +│ │└───────────────┘ │ +└──────────┴─────────────────────────────┘ +``` + +Next, NULLs intentionally introduce ambiguity. This is somewhat intentional, but consider if we have the very common case of representing missing data in a table: + +``` +CREATE TABLE dog(id SERIAL PRIMARY KEY, name TEXT NOT NULL, age INTEGER); +INSERT INTO dog(name,age) VALUES ('Sparky', NULL); +table dog; + id | name | age +----+--------+----- + 1 | Sparky | +(1 row) + +``` + +We create a table for a veterinary office with three columns, but only age can contain a NULL which we promptly insert with the first row. Now imagine you are developer who sees this table for the first time. What does a NULL `age` mean? Here are some options: + +* the veterinarian forgot to ask for the dog's age +* the veterinarian forgot to type in the dog's age +* the dog's owner doesn't know the dog's age +* the dog's age was anonymized +* the dog's information has not yet been filled out +* the dog has not yet visited the office +* the dog is dead +* the dog was never born + +There are likely more valid interpretations, yet ambiguity is a property of data we would wish to avoid in a database. Consider that some of the NULL states could result in different business logic; for example, the veterinarian should be reminded to ask for the dog's age at the next visit. + +To disambiguate these options, a developer could add a new, explanatory column: + +``` +ALTER TABLE dog ADD COLUMN age_null_reason TEXT; +UPDATE dog SET age_null_reason='awaiting pet visit' WHERE id=1; +``` + +Now we can differentiate between the ambiguous NULLs. But we actually want `age_null_reason` to be `NOT NULL` only when `age IS NULL`, so we have to create a table constraint. + +``` +ALTER TABLE dog ADD CONSTRAINT age_reason_nullability check ((age IS NULL AND age_null_reason IS NOT NULL) OR (age IS NOT NULL AND age_null_reason IS NULL)); +INSERT INTO dog(name,age,age_null_reason) VALUES ('Barky', NULL, NULL); +ERROR: new row for relation "dog" violates check constraint "age_reason_nullability" +DETAIL: Failing row contains (4, Barky, null, null). +``` + +But these are just workarounds for a faulty type system in SQL. What we really want is a type which can encompass all possible states of the dog's age. This is achievable with an algebraic data type. + +``` +TutorialD (master/main): data Age = AgeInYears Integer | VetShouldAskAge | OwnerDoesntKnowAge | UnknownAge Text +TutorialD (master/main): dog:=relation{id Integer, name Text, age Age} +TutorialD (master/main): insert dog relation{tuple{id 1, name "Sparky", age VetShouldAskAge}} +TutorialD (master/main): :showexpr dog +┌───────────────┬───────────┬──────────┐ +│age::Age │id::Integer│name::Text│ +├───────────────┼───────────┼──────────┤ +│VetShouldAskAge│1 │"Sparky" │ +└───────────────┴───────────┴──────────┘ +``` + +Algebraic data types enable arbitrary type composition. In the above Age type, not only can we encode knowledge about specific, missing data, but we even include an open-ended missing value `UnknownAge` which is a catch-all for any other reason why the age may be missing from the database. As a side benefit, these types are directly comparable using equality, so we can drop the needless complication of ternary logic. + +Let us presume that, as an SQL developer, you are now prepared to ban NULL from your database. If we constrain all columns to ensure that all data is marked as NOT NULL, then we can stop worrying about them, right? Unfortunately, NULL can still be introduced by: + +OUTER JOINs: + +``` +SELECT dog.name, owner.name FROM dog LEFT OUTER JOIN owner ON dog.owner_id=owner.id; + name | name +--------+------ + Sparky | + Slappy | + Smokey | +(3 rows) + +``` + +aggregate functions: + +``` +select sum(a) from no_rows; + sum +----- + +(1 row) + +``` + +CASE WHEN without ELSE clause: + +``` +SELECT CASE WHEN 1=0 THEN 'false cond' END; + case +------ + +(1 row) +``` + +SAFE_CAST/TRY_CAST (BigQuery/MSSQL): + +``` +SELECT SAFE_CAST('nope' AS DATE); +safe_cast +--------- + +(1 row) +``` + +There are effectively an unlimited number of ways NULLs could be reintroduced into queries, forcing SQL developers to reason about them. Even if we can wrap every conceivable value with `COALESCE()`, aren't we simply fighting a losing, up-hill battle? + +The relational algebra neither requires nor recommends SQL ternary logic with NULL. Algebraic data types better capture what NULL was supposed to mean, so can we finally drop NULL? + +### Sets Can Be Empty + +A relation as defined by the relational algebra is set of attributes (called the "header") and a set of tuples (the "body") with data and matching attributes. Therefore, empty sets for both attributes and/or the tuple set are valid and meaningful. Empty tuple sets are obviously useful for representing a starting state (we don't know anything yet), but is there a value to supporting an empty attribute set such as with a table with zero columns? + +It's rare to see an empty attribute (column set) in SQL, but it is possible. + +``` +create table emptycolumns(); +``` + +We can insert empty-attributed tuples into the table. + +``` +insert into emptycolumns select; +insert into emptycolumns select; +table emptycolumns; +-- +(2 rows) +select * from emptycolumns; +-- +(2 rows) +select distinct * from emptycolumns; +ERROR: SELECT DISTINCT must have at least one column +``` + +So, what is the value of this in SQL? Well, it's nominal which is probably why few are aware this is possible. However, a tuple with no attributes can be useful in SQL: + +``` +create table alldefaults(id SERIAL PRIMARY KEY, name TEXT DEFAULT 'unknown'); +insert into alldefaults select; +insert into alldefaults select; +table alldefaults; + id | name +----+--------- + 1 | unknown + 2 | unknown +(2 rows) +``` + +Above, we create a table with two columns which both have default values. Therefore, we can insert rows with default values via an empty `SELECT`. + +We can also join on empty attributes because tuples with empty attributes match each other. + +``` +select * from emptycolumns natural join emptycolumns AS e2; +-- +(4 rows) + +``` + +Eliding column names from the `SELECT` allows us to select zero attributes: + +``` +SELECT FROM emptycolumns; +-- +(2 rows) +``` + +In the same way that empty sets are fundamental to set theory, empty attributes are fundamental to the relational alegbra. In the relational algebra, we have two fundamental relations: "relation true" and "relation false". + +Relation true is the empty-attributed relation with one empty-attributed tuple. + +``` +TutorialD (master/main): :showexpr relation{}{tuple{}} +┌┐ +││ +├┤ +└┘ +``` + +Relation false is the empty-attributed relation with zero empty-attributed tuples. + +``` +TutorialD (master/main): :showexpr relation{}{} +┌┐ +││ +└┘ +``` + +Even if these are fundamental, how are they useful? + +Both relation true and relation false are the only two results of a relational projection on zero attributes: + +``` +TutorialD (master/main): :showexpr s +┌──────────┬────────┬───────────┬───────────────┐ +│city::Text│s#::Text│sname::Text│status::Integer│ +├──────────┼────────┼───────────┼───────────────┤ +│"Athens" │"S5" │"Adams" │30 │ +│"Paris" │"S2" │"Jones" │10 │ +│"Paris" │"S3" │"Blake" │30 │ +│"London" │"S4" │"Clark" │20 │ +│"London" │"S1" │"Smith" │20 │ +└──────────┴────────┴───────────┴───────────────┘ +TutorialD (master/main): :showexpr s{} +┌┐ +││ +├┤ +└┘ +TutorialD (master/main): :showexpr (s where false){} +┌┐ +││ +└┘ +``` + +Thus, after executing a projection on zero attributes, the result of an expression with more than zero tuples is relation true, otherwise relation false. You may also recognize these relations as identity functions. + +``` +TutorialD (master/main): :showexpr s join true = s +┌┐ +││ +├┤ +└┘ +``` + +`X join true` is always equivalent to `X`. + +``` +TutorialD (master/main): :showexpr s join false = s where false +┌┐ +││ +├┤ +└┘ +``` + +`X join false` is always equivalent to `X where false`. Any such equivalences can be used for query rewriting and optimization. + +Note that SQL does not support relational equality directly. + +### SQL Types vs. Algebraic Data Types + +Data types to model the world can be complicated. SQL's C-inspired type system falls down under anything other than basic usage. + +Imagine we are creating a survey with answers of varying types such as multiple choice and free-form text. + +``` +CREATE TABLE survey(question TEXT NOT NULL, answer ???); +``` + +SQL types force our hand to consider "alternative" type designs. + +We can cram all the options into one table and use NULL as a placeholder to indicate a value is not relevant. + +``` +CREATE TABLE survey(question TEXT NOT NULL, answer_a TEXT, answer_b TEXT, answer_c TEXT, answer_d TEXT, freeformtext BOOLEAN); +``` + +This design hints that we can create up to four multiple-choice options *or* a free form text field for a user to answer the question if `freeformtext` is true. We could also include a convoluted constraint which ensures that `answer_X` columns are NULL if `freeformtext` is true and a constraint that ensures that `answer_b` is NOT NULL only if `answer_a` is filled in and so forth, but we are quickly falling off the rails in terms of complexity- all for a survey question. + +Another design is to leverage table joins: + +``` +CREATE TABLE multi_answer(id INTEGER NOT NULL, answer_a TEXT, answer_b TEXT, answer_c TEXT, answer_d TEXT); +CREATE TABLE survey(question TEXT NOT NULL, multi_answer_id INTEGER REFERENCES multi_answer(id), freeformtext BOOLEAN); +``` + +This makes some of the constraints easier to write, but is otherwise just shuffling data around for little benefit. + +A worse-but-common design is to shoehorn the data into a JSON structure. + +``` +CREATE TABLE survey(question TEXT NOT NULL, answer JSON NOT NULL); +insert into survey(question,answer) values ('What is your favorite sea animal?', '{"answer_a":"Seahorse", "answer_b":"Clam", "answer_c":"Shark", "answer_d":"Urchin"}'); +``` + +Or maybe the answers should just be a JSON list. That would also be valid. But which format would the application prefer and what is enforcing the JSON format's coherency and relevance to our use-case? + +Consider if we used this format in our application then realized that we want to support an answer within an integer range (such as having the user select the number of children they have). Would we be expected to shoehorn this new requirement into the JSON blob or create a new column to indicate which "version" of the JSON blob format we expect? + +In the above examples, we are merely working around the lack of proper, complex types in SQL. In a database that supports algebraic data types, this is a non-issue: + +``` +TutorialD (master/main): data Answers = MultiChoice (List Text) | FreeformText +TutorialD (master/main): survey := relation{tuple{question "Who is your favorite actor?", answer FreeformText}, tuple{question "How many siblings do you have?", answer MultiChoice (Cons "1" (Cons "2" (Cons "More Than 2" Empty)))}} +TutorialD (master/main): :showexpr survey +┌────────────────────────────────────────────────────────────┬────────────────────────────────┐ +│answer::Answers │question::Text │ +├────────────────────────────────────────────────────────────┼────────────────────────────────┤ +│FreeformText │"Who is your favorite actor?" │ +│MultiChoice (Cons "1" (Cons "2" (Cons "More Than 2" Empty)))│"How many siblings do you have?"│ +└────────────────────────────────────────────────────────────┴────────────────────────────────┘ +``` + +First, we define a new algebraic data type, enumerating all possible values. Then we use it. The type is both forwards- and backwards-compatible, completely validated by construction, and never ambiguous. + +### SQL Window Queries vs. Nested Relations + +SQL bolted on the concept of "window functions" which operate on subsets of the tuples of a given query with relation to the "current row" being considered. It is often used in analytical queries. + +``` +SELECT depname, empno, salary, + rank() OVER (PARTITION BY depname ORDER BY salary DESC) +FROM empsalary; + depname | empno | salary | avg +-----------+-------+--------+----------------------- + develop | 11 | 5200 | 5020.0000000000000000 + develop | 7 | 4200 | 5020.0000000000000000 + develop | 9 | 4500 | 5020.0000000000000000 + develop | 8 | 6000 | 5020.0000000000000000 + develop | 10 | 5200 | 5020.0000000000000000 + personnel | 5 | 3500 | 3700.0000000000000000 + personnel | 2 | 3900 | 3700.0000000000000000 + sales | 3 | 4800 | 4866.6666666666666667 + sales | 1 | 5000 | 4866.6666666666666667 + sales | 4 | 4800 | 4866.6666666666666667 +(10 rows) +``` + +In the above example, we query employees per-department ranked by their salary. Note that this query is completely unrepresentable in the relational algebra for multiple reasons: + +* tuples within a relation have no ordering because sets have no ordering +* there is no concept of a "current row" in the relational algebra +* a set of tuples cannot be placed together (again, there is no ordering) + +Window functions in SQL are a workaround for the lack of nested relation support. Nested relations are a fundamental component of the relational algebra. + +``` +TutorialD (master/main): :showexpr s group ({all but status} as s) +┌─────────────────────────────────────────────┬───────────────┐ +│s::relation {s#::Text,sname::Text,city::Text}│status::Integer│ +├─────────────────────────────────────────────┼───────────────┤ +│┌──────────┬────────┬───────────┐ │30 │ +││city::Text│s#::Text│sname::Text│ │ │ +│├──────────┼────────┼───────────┤ │ │ +││"Athens" │"S5" │"Adams" │ │ │ +││"Paris" │"S3" │"Blake" │ │ │ +│└──────────┴────────┴───────────┘ │ │ +│┌──────────┬────────┬───────────┐ │20 │ +││city::Text│s#::Text│sname::Text│ │ │ +│├──────────┼────────┼───────────┤ │ │ +││"London" │"S4" │"Clark" │ │ │ +││"London" │"S1" │"Smith" │ │ │ +│└──────────┴────────┴───────────┘ │ │ +│┌──────────┬────────┬───────────┐ │10 │ +││city::Text│s#::Text│sname::Text│ │ │ +│├──────────┼────────┼───────────┤ │ │ +││"Paris" │"S2" │"Jones" │ │ │ +│└──────────┴────────┴───────────┘ │ │ +└─────────────────────────────────────────────┴───────────────┘ +``` + +In the above example, we group suppliers in subrelations based on status value. Note that the subrelations have no inherent ordering internally or relative to each other. We can leverage subrelation groupings to apply aggregate functions, apply rankings, and more. Furthermore, nested relations can contain nested relations, unlike window queries. + +## On Building Sandcastles On Beaches + +The derisive term "legacy" is not applied to technology merely because it is old. Software can *instantly* become "legacy" code if it fails to address the immediate or imminent use-cases. Developers object to such a definition because, based on this definition, nearly all code is instant legacy code and their egos are often tied to code cleverness or corners cut. Instead of becoming defensive, developers can step back and reassess: how can I stop writing legacy code? Why does most of my code inevitably end up in the trash can? + +Such a line of thinking should lead the software developer to rephrase the question: what is reliable and permanent in software? That could be a complex question except for the fact that the [Curry-Howard isomorphism](https://en.wikipedia.org/wiki/Curry%E2%80%93Howard_correspondence) answers it for us. The permanent concepts that enable permanent software is math itself! (The Curry-Howard isomorphism states that any program can be represented as a mathematical proof and vice versa.) Thus, by creating software which adheres strongly to mathematical concepts, we give ourselves the best chance to write long-lasting code. + +For example, column indexing is not included in the relational algebra- why would it be? - so deciding which representations or optimizations of the data is left to the database. Indexes are equivalent to query planner "hints" whereby we provide the query planner a potential execution path. The alternative, however, is to leverage the relational algebra itself to provide the execution paths and relegate human usage of the database to high-level concepts to manipulate data instead of manage how it's queried, which, ideally, is the always the job of a DBMS. + +Project:M36 purports to follow the mathematics of the relational algebra closely instead of choosing to cut corners so as to be able to experiment with the complete, mostly unexplored richness of the relational algebra. + +By following the math, we can even find new means of executing queries. For example, there is much excitement around analytics-oriented, columnar-focused DBMSes. Wouldn't it make more sense if the DBMS could choose an arbitrary storage format based on how the data will be queried. A proper DBMS anticipates the needs of the application using heuristics or machine learning to determine how best to execute queries- it makes no sense to bake in limitations so that data can only be sliced and processed in limited ways. + +Not all queries should be executed using the same planner strategies. For example, analytics queries could have a lower priority than transactional data manipulations. Such prioritization could limit how much IO, CPU, or network time the analytical queries could use by changing the execution plan. The DBMS could store data in multiple ways to best serve the needs of the application and send different queries through different data representations such as column vs. row stores. The same data could be represented any number of times on disk in various formats to best serve the queries of the application. None of this is possible if we peg tables to files and force users to choose various representations of the data such as with indexes and materialized views. + + +## Conclusion + +For better or worse, SQL will likely be one of the calcified 1960s technologies used into the near future. SQL includes a number of mistaken assumptions and design-by-committee decisions that have not held up over time, but that doesn't mean we can't aspire to better. + +Project:M36 offers an upgrade path to the real relational algebra by offering an SQL frontend bolted onto a relational algebra engine, further underscoring how limiting SQL actually is, especially regarding the lack of nested relations, complex types, and math-derived optimization equivalences. Every SQL product offers a dialect of SQL and Project:M36 is no exception, naming it "SQLegacy" to emphasize that SQL should be demphasized. + +The SQLegacy console enables this proposed transition via a relational-algebra-targeted language called TutorialD. The console convers SQL to TutorialD and displays it to the user: + +``` +SQLegacy (master/main): import example cjdate; +SQLegacy (master/main): select status from s where city='London' order by status; +[Equivalent TutorialD] :showdataframe ((s where sql_coalesce_bool( sql_equals( @city, "London" ) ))){status} orderby {status ascending} +┌──┬────────────────┐ +│DF│status::Integer⬆│ +├──┼────────────────┤ +│1 │20 │ +└──┴────────────────┘ + +``` + +Note that SQLegacy always returns dataframes as indicated by "DF" in the top right of the diagram. That's because SQLegacy supports post-processing relational expressions into dataframes which do support ordering. SQL results are always ordered, even when arbitrarily. + +The SQLegacy dialect and TutorialD implementations can co-exist and execute queries on the same databases. Since the Project:M36 software is built on the relational algebra on not SQL, other DBMS languages could be added, too. + +Relying on the relational algebra simply opens more doors for correctness, cohesiveness, productivity, optimizations, and more. + +## Bibliography + +Codd, E.F. [*Serious Flaws in SQL*](https://dl.acm.org/doi/pdf/10.5555/77708.C1065772) From 3a09ee50aa0fc55e3ef09fa3f8caff0ab9919c23 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 6 Jun 2024 02:26:10 -0400 Subject: [PATCH 132/170] add sqlegacy documentation --- docs/sqlegacy.markdown | 44 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) create mode 100644 docs/sqlegacy.markdown diff --git a/docs/sqlegacy.markdown b/docs/sqlegacy.markdown new file mode 100644 index 00000000..c0a934a7 --- /dev/null +++ b/docs/sqlegacy.markdown @@ -0,0 +1,44 @@ +# SQLegacy: SQL on a Relational Algebra Engine + +## Introduction + +Project:M36 is a relational algebra engine supporting Haskell, TutorialD, and SQL interfaces. While SQL purports to based on the relational algebra, SQL [takes liberties](why_sqlegacy.markdown) which cause it to stray from the mathematics of the algebra. Regardless, SQL is a popular and well-supported language for database interaction, so Project:M36 supports its own dialect of SQL called "SQLegacy" to emphasize that it is not the preferred interface to the relational algebra. This document explains how to use the SQLegacy console for legacy SQL usage. + +## Setting Up + +To run the SQLegacy interactive console: + +``` +docker run -it projectm36/project-m36 sqlegacy +``` + +results in: + +``` +Project:M36 SQLegacy Interpreter 0.9.9 +SQL does not support the complete relational algebra. To access the complete relational algebra, use the bundled "tutd" interpreter. +Type "help" for more information. +SQLegacy (master/main): +``` + +## SQL Commands + +The following commands are supported: + +* `SELECT` +* `UPDATE` +* `DELETE` +* `INSERT` +* `CREATE TABLE` +* `DROP TABLE` +* `BEGIN` +* `COMMIT` +* `ROLLBACK` +* `IMPORT EXAMPLE CJDATE;` to load your database with tables "s", "sp", and "p" from C.J. Date's books on the relational algebra + +More information on how to use SQL can be found at existing [PostgreSQL tutorials](https://www.postgresqltutorial.com/). + + +## Limitations + +SQLegacy does not support duplicate rows in any context. To create "duplicate" rows, create a surrogate primary key column such as with a UUID. \ No newline at end of file From b118f25ea5d253e8888388f36720d22ee533b458 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 6 Jun 2024 02:26:52 -0400 Subject: [PATCH 133/170] reference sqlegacy documentation --- README.markdown | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/README.markdown b/README.markdown index 4d058661..7a348057 100644 --- a/README.markdown +++ b/README.markdown @@ -37,6 +37,7 @@ Project:M36 is written entirely in the [Haskell programming language](https://ww Project:M36 supports multiple frontends which target different audiences. * learn about the relational algebra via TutorialD +* use SQLegacy to learn how SQL differs from the relational algebra * store and manipulate databases * use Project:M36 as a native Haskell database backend @@ -68,7 +69,13 @@ Project:M36 supports multiple frontends which target different audiences. 1. [ACID Database Properties](docs/acid_assessment.markdown) 1. [On NULL (in SQL)](docs/on_null.markdown) 1. [Reaching "Out of the Tarpit" with Project:M36](docs/reaching_out_of_the_tarpit.markdown) -1. [An Architecture for Data Independence](docs/data_independence.markdown) +1. [An Architecture for Data Independence](docs/data_independence.markdown)' + + +### SQL Support + +1. [Why SQLegacy?](docs/why_sqlegacy.markdown) +1. [SQLegacy Documentation](docs/sqlegacy.markdown) ### Advanced Features From b5765510f819ea6d890746969fe2763dfb91c4c2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 6 Jun 2024 02:28:36 -0400 Subject: [PATCH 134/170] add help to sqlegacy console --- project-m36.cabal | 1 + src/bin/SQL/Interpreter.hs | 13 +++++++++++-- src/bin/SQL/Interpreter/Info.hs | 9 +++++++++ src/bin/SQL/Interpreter/sqlegacy.hs | 2 +- 4 files changed, 22 insertions(+), 3 deletions(-) create mode 100644 src/bin/SQL/Interpreter/Info.hs diff --git a/project-m36.cabal b/project-m36.cabal index 47ada30b..781d6e54 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -300,6 +300,7 @@ Executable sqlegacy SQL.Interpreter.DBUpdate, SQL.Interpreter.CreateTable, SQL.Interpreter.DropTable, + SQL.Interpreter.Info, TutorialD.Printer, TutorialD.Interpreter.Base diff --git a/src/bin/SQL/Interpreter.hs b/src/bin/SQL/Interpreter.hs index 8e07bbb5..8bdc4d6c 100644 --- a/src/bin/SQL/Interpreter.hs +++ b/src/bin/SQL/Interpreter.hs @@ -10,6 +10,7 @@ import SQL.Interpreter.ImportBasicExample import SQL.Interpreter.TransactionGraphOperator import SQL.Interpreter.Select import SQL.Interpreter.DBUpdate +import SQL.Interpreter.Info import ProjectM36.SQL.DBUpdate import qualified Data.Text as T import qualified ProjectM36.Client as C @@ -20,7 +21,8 @@ data SQLCommand = RODatabaseContextOp Query | -- SELECT DatabaseContextExprOp DatabaseContextExpr | DBUpdateOp [DBUpdate] | -- INSERT, UPDATE, DELETE, CREATE TABLE, DROP TABLE ImportBasicExampleOp ImportBasicExampleOperator | -- IMPORT EXAMPLE cjdate - TransactionGraphOp TransactionGraphOperator -- COMMIT, ROLLBACK + TransactionGraphOp TransactionGraphOperator | -- COMMIT, ROLLBACK + InfoOp InfoOperator -- help deriving (Show) type SQLCommands = [SQLCommand] @@ -32,7 +34,9 @@ semiCommand :: Parser SQLCommand semiCommand = (parseRODatabaseContextOp <|> parseDatabaseContextExprOp <|> parseTransactionGraphOp <|> - parseImportBasicExampleOp) <* semi + parseImportBasicExampleOp <|> + parseInfoOperator + ) <* semi parseRODatabaseContextOp :: Parser SQLCommand @@ -47,6 +51,9 @@ parseTransactionGraphOp = TransactionGraphOp <$> transactionGraphOperatorP parseDatabaseContextExprOp :: Parser SQLCommand parseDatabaseContextExprOp = DBUpdateOp <$> dbUpdatesP +parseInfoOperator :: Parser SQLCommand +parseInfoOperator = InfoOp <$> infoP + evalSQLInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> [SQLCommand] -> IO [ConsoleResult] evalSQLInteractive sessionId conn _safeFlag _interactiveConsole = mapM evalOneCommand @@ -87,6 +94,8 @@ evalSQLInteractive sessionId conn _safeFlag _interactiveConsole = eHandler $ C.rollback sessionId conn TransactionGraphOp Begin -> pure $ DisplayHintWith "Advisory Warning: BEGIN is redundant as transaction is started automatically." QuietSuccessResult + InfoOp HelpOperator -> + pure $ DisplayResult "The SQLegacy Console supports common SQL expressions. To import the C.J.Date examples:\n IMPORT EXAMPLE CJDATE;\nExample queries:\n SELECT status FROM s WHERE city='London';\nSELECT * FROM s NATURAL JOIN sp;\nExample statements:\n INSERT INTO s(city,s#,sname,status) VALUES ('Frankfurt', 'S6', 'Brians', 40);\n DELETE FROM s WHERE city='London';\n UPDATE s SET status=20 WHERE city='Paris';" where eHandler io = do eErr <- io diff --git a/src/bin/SQL/Interpreter/Info.hs b/src/bin/SQL/Interpreter/Info.hs new file mode 100644 index 00000000..7bc8c7c9 --- /dev/null +++ b/src/bin/SQL/Interpreter/Info.hs @@ -0,0 +1,9 @@ +module SQL.Interpreter.Info where +import ProjectM36.Interpreter +import SQL.Interpreter.Base +import Data.Functor + +data InfoOperator = HelpOperator deriving Show + +infoP :: Parser InfoOperator +infoP = reserved "help" $> HelpOperator diff --git a/src/bin/SQL/Interpreter/sqlegacy.hs b/src/bin/SQL/Interpreter/sqlegacy.hs index 0edc0b5e..19c3a818 100644 --- a/src/bin/SQL/Interpreter/sqlegacy.hs +++ b/src/bin/SQL/Interpreter/sqlegacy.hs @@ -28,7 +28,7 @@ printWelcome :: IO () printWelcome = do putStrLn ("Project:M36 SQLegacy Interpreter " ++ VERSION_project_m36) putStrLn "SQL does not support the complete relational algebra. To access the complete relational algebra, use the bundled \"tutd\" interpreter." - putStrLn "Type \"help\" for more information." + putStrLn "Type \"help;\" for more information." sqlReprLoop :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () sqlReprLoop sessionId conn mPromptLength userInput = do From b745c18d5c75bbab8a99af1a83d2a480804a9edd Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 6 Jun 2024 02:30:40 -0400 Subject: [PATCH 135/170] fix non-letter-based operators in scalar expressions add test for where + order by --- src/bin/SQL/Interpreter/Select.hs | 5 +++++ src/lib/ProjectM36/Attribute.hs | 8 +++++++- src/lib/ProjectM36/Base.hs | 2 +- src/lib/ProjectM36/Client.hs | 2 +- src/lib/ProjectM36/RelationalExpression.hs | 9 ++++++--- test/SQL/InterpreterTest.hs | 5 +++++ 6 files changed, 25 insertions(+), 6 deletions(-) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index ec470e3f..e7cd6421 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -9,6 +9,7 @@ import SQL.Interpreter.Base import Data.Text (Text, splitOn) import qualified Data.Text as T import Data.Functor +import Data.Char (isLetter) import qualified Data.List.NonEmpty as NE @@ -192,7 +193,11 @@ qualifiedOperatorP :: Text -> Parser OperatorName qualifiedOperatorP sym = OperatorName <$> segmentsP (splitOn "." sym) <* spaceConsumer where + isLetters :: Text -> Bool + isLetters t = T.all isLetter t segmentsP :: [Text] -> Parser [Text] + -- simple case for non-string-based operators + segmentsP [op] | not (isLetters op) = qualifiedNameSegment op *> pure [op] segmentsP segments = case segments of [] -> fail "empty operator" [seg] -> do diff --git a/src/lib/ProjectM36/Attribute.hs b/src/lib/ProjectM36/Attribute.hs index 2bd443b1..634d1169 100644 --- a/src/lib/ProjectM36/Attribute.hs +++ b/src/lib/ProjectM36/Attribute.hs @@ -135,6 +135,11 @@ renameAttributes oldAttrName newAttrName attrs = Attributes { else attr +renameAttributes' :: S.Set (AttributeName, AttributeName) -> Attributes -> Attributes +renameAttributes' renameSet attrs = + foldr (\(old, new) acc -> renameAttributes old new acc) attrs renameSet + + atomTypeForAttributeName :: AttributeName -> Attributes -> Either RelationalError AtomType atomTypeForAttributeName attrName attrs = do (Attribute _ atype) <- attributeForName attrName attrs @@ -228,7 +233,8 @@ verifyAttributes :: Attributes -> Either RelationalError Attributes verifyAttributes attrs = if vecSet == attributesSet attrs then pure attrs - else + else do + traceShowM ("verify"::String, vecSet, attributesSet attrs) Left (TupleAttributeTypeMismatchError diffAttrs) where vecSet = V.foldr' HS.insert HS.empty (attributesVec attrs) diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 82d7d115..7731fe63 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -242,7 +242,7 @@ data RelationalExprBase a = --- | Create a join of two relational expressions. The join occurs on attributes which are identical. If the expressions have no overlapping attributes, the join becomes a cross-product of both tuple sets. Join (RelationalExprBase a) (RelationalExprBase a) | --- | Rename an attribute (first argument) to another (second argument). - Rename (S.Set (AttributeName, AttributeName)) (RelationalExprBase a) | + Rename (S.Set (AttributeName, AttributeName)) (RelationalExprBase a) | -- should the rename be a Map? --- | Return a relation containing all tuples of the first argument which do not appear in the second argument (minus). Difference (RelationalExprBase a) (RelationalExprBase a) | --- | Create a sub-relation composed of the first argument's attributes which will become an attribute of the result expression. The unreferenced attributes are not altered in the result but duplicate tuples in the projection of the expression minus the attribute names are compressed into one. For more information, diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs index 8f6c251c..8c8e6093 100644 --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -1135,7 +1135,7 @@ convertSQLDBUpdates sessionId (InProcessConnection conf) updates = do Right (session, _schema) -> do -- TODO: enable SQL to leverage isomorphic schemas let ctx = Sess.concreteDatabaseContext session reEnv = RE.mkRelationalExprEnv ctx transGraph - typeF = optimizeAndEvalRelationalExpr reEnv + typeF = optimizeAndEvalRelationalExpr reEnv -- TODO: replace with typeForRelationalExpr -- convert SQL data into DataFrameExpr case evalConvertM mempty (convertDBUpdates typeF updates) of Left err -> pure (Left (SQLConversionError err)) diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index 3896987b..9be7824f 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -25,6 +25,7 @@ import qualified Data.Set as S import Control.Monad.State hiding (join) import Data.Bifunctor (second) import Data.Maybe +import Data.Tuple (swap) import Data.Either import Data.Char (isUpper) import Data.Time @@ -803,7 +804,7 @@ predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) Left err2@(NoSuchAttributeNamesError _) -> Left err2 Left err -> Left err Left err -> Left err - if atomExprType /= A.atomType attr then + if atomExprType /= A.atomType attr then do throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr])) else pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of @@ -1097,7 +1098,8 @@ evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do tup = mkRelationTuple tupAttrs atoms finalAttrs = fromMaybe tupAttrs mAttrs --verify that the attributes match - when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs) + when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ do + throwError (TupleAttributeTypeMismatchError tupAttrs) --we can't resolve types here- they have to be resolved at the atom level where the graph ref is held --tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup)) let tup' = reorderTuple finalAttrs tup @@ -1530,7 +1532,8 @@ addTargetTypeHints targetAttrs expr = Join a b -> Join (hint a) (hint b) Rename rens e -> - Rename rens (hint e) + let renamedAttrs = A.renameAttributes' (S.map swap rens) targetAttrs in + Rename rens (addTargetTypeHints renamedAttrs e) Difference a b -> Difference (hint a) (hint b) Group attrs gname e -> diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index 603d14d3..ad9c4fa6 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -69,6 +69,11 @@ testSelect = TestCase $ do "((s where sql_coalesce_bool(sql_equals(@status,20))){city})", "((s where status=20){city})" ), + -- restriction + order by + ("SELECT status FROM s where status=20 order by status", + "((s where sql_coalesce_bool(sql_equals(@status,20))){status}) orderby {status}", + "((s where status=20){status}) orderby {status}" + ), -- restriction with asterisk and qualified name ("SELECT * FROM s WHERE \"s\".\"status\"=20", "(s where sql_coalesce_bool(sql_equals(@status,20)))", From a80c06059412c58a6d473d4ed3f126f1308d8efc Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 6 Jun 2024 02:35:39 -0400 Subject: [PATCH 136/170] fix hlint suggestions --- src/bin/SQL/Interpreter/Select.hs | 4 ++-- src/lib/ProjectM36/Attribute.hs | 1 - 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/bin/SQL/Interpreter/Select.hs b/src/bin/SQL/Interpreter/Select.hs index e7cd6421..c29cd53d 100644 --- a/src/bin/SQL/Interpreter/Select.hs +++ b/src/bin/SQL/Interpreter/Select.hs @@ -194,10 +194,10 @@ qualifiedOperatorP sym = OperatorName <$> segmentsP (splitOn "." sym) <* spaceConsumer where isLetters :: Text -> Bool - isLetters t = T.all isLetter t + isLetters = T.all isLetter segmentsP :: [Text] -> Parser [Text] -- simple case for non-string-based operators - segmentsP [op] | not (isLetters op) = qualifiedNameSegment op *> pure [op] + segmentsP [op] | not (isLetters op) = qualifiedNameSegment op $> [op] segmentsP segments = case segments of [] -> fail "empty operator" [seg] -> do diff --git a/src/lib/ProjectM36/Attribute.hs b/src/lib/ProjectM36/Attribute.hs index 634d1169..3f30afd7 100644 --- a/src/lib/ProjectM36/Attribute.hs +++ b/src/lib/ProjectM36/Attribute.hs @@ -234,7 +234,6 @@ verifyAttributes attrs = if vecSet == attributesSet attrs then pure attrs else do - traceShowM ("verify"::String, vecSet, attributesSet attrs) Left (TupleAttributeTypeMismatchError diffAttrs) where vecSet = V.foldr' HS.insert HS.empty (attributesVec attrs) From 1e308332569c41c7b6a54e449bf5330410a79f59 Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 6 Jun 2024 12:36:46 -0400 Subject: [PATCH 137/170] increment major version to 1.0.0 --- Changelog.markdown | 5 +++++ project-m36.cabal | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/Changelog.markdown b/Changelog.markdown index aaca84ee..4e2dc79f 100644 --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,8 @@ +# 2024-06-06 (v1.0.0) + +* add support for relational expression evaluation against sub-relations +* add support for SQL dialect and console called "SQLegacy" + # 2024-01-12 (v0.9.9) * revert to using streamly 0.9.0 due to over-the-wire corruption bug in 0.10.0 diff --git a/project-m36.cabal b/project-m36.cabal index 781d6e54..e3d5a2cf 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 0.9.9 +Version: 1.0.0 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple From 8317bf3aed9ddc73aab4387c8ebb748808efc43a Mon Sep 17 00:00:00 2001 From: AgentM Date: Thu, 6 Jun 2024 13:37:55 -0400 Subject: [PATCH 138/170] update README to mention SQL support more prominently --- README.markdown | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/README.markdown b/README.markdown index 7a348057..8158ace6 100644 --- a/README.markdown +++ b/README.markdown @@ -12,13 +12,15 @@ ## Introduction -Project:M36 implements a relational algebra engine as inspired by the writings of Chris Date. +Project:M36 implements a relational algebra engine as inspired by the writings of Chris Date. Project:M36 supports both SQL and TutorialD interactive access. ## Quick Install -Project:M36 can be downloaded and run via docker, which supports Windows 10, macOS, and Linux. +Project:M36 can be downloaded and run via docker, which supports Windows 10+, macOS, and Linux. -Run `docker run -it projectm36/project-m36 tutd` to start the TutorialD command line interface. +Run `docker run -it projectm36/project-m36 tutd` to start the [TutorialD](docs/tutd_tutorial.markdown) command line interface. + +Run `docker run -it projectm36/project-m36 sqlegacy` to start the [SQLegacy](docs/sqlegacy.markdown) (SQL dialect) command line interface. ## Description From 533dde9fe325cac2801bd4e03a59a27f34464f38 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 11 Jun 2024 23:29:21 -0400 Subject: [PATCH 139/170] WIP agg function + sub attribute --- src/lib/ProjectM36/Base.hs | 11 +++++++---- src/lib/ProjectM36/NormalizeExpr.hs | 4 ++-- src/lib/ProjectM36/RelationalExpression.hs | 20 +++++++++++--------- src/lib/ProjectM36/Shortcuts.hs | 4 ++-- src/lib/ProjectM36/Tuple.hs | 3 +++ src/lib/ProjectM36/WithNameExpr.hs | 4 ++-- 6 files changed, 27 insertions(+), 19 deletions(-) diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 7731fe63..bcd2d261 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -233,9 +233,9 @@ data RelationalExprBase a = --relational variables should also be able to be explicitly-typed like in Haskell --- | Reference a relation variable by its name. RelationVariable RelVarName a | - --- | Create a projection over attribute names. (Note that the 'AttributeNames' structure allows for the names to be inverted.) + -- | Extract a relation from an `Atom` that is a nested relation (a relation within a relation). RelationValuedAttribute AttributeName | - -- | Extract a relation from an `Atom` that is a nested relation (a relation within a relation). + --- | Create a projection over attribute names. (Note that the 'AttributeNames' structure allows for the names to be inverted.) Project (AttributeNamesBase a) (RelationalExprBase a) | --- | Create a union of two relational expressions. The expressions should have identical attributes. Union (RelationalExprBase a) (RelationalExprBase a) | @@ -504,10 +504,13 @@ instance Hashable AtomExpr type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker +type AggAtomFuncExprInfo = Maybe AttributeName + -- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple. -data AtomExprBase a = AttributeAtomExpr !AttributeName | +data AtomExprBase a = AttributeAtomExpr AttributeName | NakedAtomExpr !Atom | - FunctionAtomExpr FunctionName [AtomExprBase a] a | + FunctionAtomExpr !FunctionName [AtomExprBase a] AggAtomFuncExprInfo a | + -- as a simple, first aggregation case, we can only apply an aggregation to a RelationAtom while "selecting" one attribute RelationAtomExpr (RelationalExprBase a) | IfThenAtomExpr (AtomExprBase a) (AtomExprBase a) (AtomExprBase a) | -- if, then, else ConstructedAtomExpr DataConstructorName [AtomExprBase a] a diff --git a/src/lib/ProjectM36/NormalizeExpr.hs b/src/lib/ProjectM36/NormalizeExpr.hs index 9546b0f7..b20569f3 100644 --- a/src/lib/ProjectM36/NormalizeExpr.hs +++ b/src/lib/ProjectM36/NormalizeExpr.hs @@ -113,8 +113,8 @@ processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = processAtomExpr :: AtomExpr -> ProcessExprM GraphRefAtomExpr processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom -processAtomExpr (FunctionAtomExpr fName atomExprs ()) = - FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> askMarker +processAtomExpr (FunctionAtomExpr fName atomExprs aggInfo ()) = + FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> pure aggInfo <*> askMarker processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr processAtomExpr (IfThenAtomExpr ifE thenE elseE) = IfThenAtomExpr <$> processAtomExpr ifE <*> processAtomExpr thenE <*> processAtomExpr elseE diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index 9be7824f..3f32c036 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -855,17 +855,20 @@ extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrNa Right (tupleAtomExtend newAttrName atom tup) ) + + evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom evalGraphRefAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of - Right atom -> pure atom - Left err@(NoSuchAttributeNamesError _) -> do - env <- askEnv - case gre_extra env of - Nothing -> throwError err - Just (Left ctxtup) -> lift $ except $ atomForAttributeName attrName ctxtup - Just (Right _) -> throwError err - Left err -> throwError err + Right atom -> pure atom + Left err@(NoSuchAttributeNamesError _) -> do + env <- askEnv + case gre_extra env of + Nothing -> throwError err + Just (Left ctxtup) -> lift $ except $ atomForAttributeName attrName ctxtup + Just (Right _) -> throwError err + Left err -> throwError err + evalGraphRefAtomExpr _ (NakedAtomExpr atom) = pure atom evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName' arguments tid) = do argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments @@ -1237,7 +1240,6 @@ typeForGraphRefRelationalExpr (RelationValuedAttribute attrName) = do case typ of RelationAtomType relAttrs -> pure $ emptyRelationWithAttrs relAttrs other -> throwError (AtomTypeMismatchError (RelationAtomType A.emptyAttributes) other) - typeForGraphRefRelationalExpr (Project attrNames expr) = do exprType' <- typeForGraphRefRelationalExpr expr projectionAttrs <- evalGraphRefAttributeNames attrNames expr diff --git a/src/lib/ProjectM36/Shortcuts.hs b/src/lib/ProjectM36/Shortcuts.hs index 048bad64..fd883179 100644 --- a/src/lib/ProjectM36/Shortcuts.hs +++ b/src/lib/ProjectM36/Shortcuts.hs @@ -81,7 +81,7 @@ instance (Convertible a AtomExpr, KnownSymbol x) => IsLabel x (a -> (AttributeNa -- -- This usage is not working in RestrictionPredicateExpr and AttributeExtendTupleExpr. Use f "a" [1] instead. instance (KnownSymbol x, Convertible a AtomExpr) => IsLabel x ([a] -> AtomExpr) where - fromLabel = \as' -> FunctionAtomExpr name (map convert as') () + fromLabel = \as' -> FunctionAtomExpr name (map convert as') Nothing () where name = T.pack $ symbolVal @x Proxy instance (KnownSymbol x) => IsLabel x AtomExpr where @@ -175,7 +175,7 @@ instance Convertible RelVarName RelationalExpr where -- works in RestrictedPredicateExpr and AttributeExtendTupleExpr -- usage: f "gte" [1] f :: Convertible a AtomExpr => FunctionName -> [a] -> AtomExpr -f n as' = FunctionAtomExpr n (map convert as') () +f n as' = FunctionAtomExpr n (map convert as') Nothing () -- DatabaseContextExpr -- define diff --git a/src/lib/ProjectM36/Tuple.hs b/src/lib/ProjectM36/Tuple.hs index 7a286db6..c7fb0627 100644 --- a/src/lib/ProjectM36/Tuple.hs +++ b/src/lib/ProjectM36/Tuple.hs @@ -222,3 +222,6 @@ trimTuple index (RelationTuple attrs vals) = RelationTuple newAttrs (V.drop index vals) where newAttrs = A.drop index attrs + + + diff --git a/src/lib/ProjectM36/WithNameExpr.hs b/src/lib/ProjectM36/WithNameExpr.hs index ecc1d2ae..d45f1376 100644 --- a/src/lib/ProjectM36/WithNameExpr.hs +++ b/src/lib/ProjectM36/WithNameExpr.hs @@ -85,8 +85,8 @@ substituteWithNameMacrosAtomExpr macros atomExpr = case atomExpr of e@AttributeAtomExpr{} -> e e@NakedAtomExpr{} -> e - FunctionAtomExpr fname atomExprs tid -> - FunctionAtomExpr fname (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid + FunctionAtomExpr fname atomExprs aggInfo tid -> + FunctionAtomExpr fname (map (substituteWithNameMacrosAtomExpr macros) atomExprs) aggInfo tid RelationAtomExpr reExpr -> RelationAtomExpr (substituteWithNameMacros macros reExpr) IfThenAtomExpr ifE thenE elseE -> From 197f3e6a71eceb56b829bf15ddc4493e521c1a48 Mon Sep 17 00:00:00 2001 From: AgentM Date: Tue, 11 Jun 2024 23:29:45 -0400 Subject: [PATCH 140/170] fix typos in why_sqlegacy --- docs/why_sqlegacy.markdown | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/docs/why_sqlegacy.markdown b/docs/why_sqlegacy.markdown index d5e61f02..d185d706 100644 --- a/docs/why_sqlegacy.markdown +++ b/docs/why_sqlegacy.markdown @@ -25,7 +25,7 @@ While SQL, as a declarative language, does better on the "options" axis than key ### Project:M36+TutorialD vs. SQL -Project:M36 is a ground-up reimaginging of what a relational algebra engine could be. It was born out of the frustrations of dealing with SQL so it aims to avoid the pitfalls of SQL. However, any serious, production DBMS nowadays supports SQL out of necessity- Project:M36 is no exception. Deliberate care was taken to ensure that SQL is bolted on top of a relational algebra core. To achieve this, a database interaction language apart from SQL was required: TutorialD. TutorialD has been developed over decades by database expert C.J. Date, an author who also recognized the irreconciable flaws of SQL. +Project:M36 is a ground-up reimagining of what a relational algebra engine could be. It was born out of the frustrations of dealing with SQL so it aims to avoid the pitfalls of SQL. However, any serious, production DBMS nowadays supports SQL out of necessity- Project:M36 is no exception. Deliberate care was taken to ensure that SQL is bolted on top of a relational algebra core. To achieve this, a database interaction language apart from SQL was required: TutorialD. TutorialD has been developed over decades by database expert C.J. Date, an author who also recognized the irreconciable flaws of SQL. Project:M36's SQL shim over a relational algebra core makes SQL flaws more obvious through comparative implementation. Unfortunately, it is not even true that SQL supports a strict subset of the relational algebra. @@ -259,7 +259,7 @@ In this case, SQL forces us to name the columns to be able to use them. Why shou SQL allows column names to be repeated: ``` -SELECY 1 AS a, 2 AS a; +SELECT 1 AS a, 2 AS a; a | a ---+--- 1 | 2 @@ -321,7 +321,6 @@ TutorialD (master/main): :showexpr (relation{tuple{a 1,b 2},tuple{a -1,b 3}}:{a2 │1 │ └───────────┘ ``` - First, the extension with `abs()` occurs, then we project on the new attribute's name. Done. ### NULL: A Billion Dollar Boondoggle @@ -334,7 +333,7 @@ First and foremost, the presence of NULLs make it difficult for an SQL developer SELECT AVG(age) FROM citizen; ``` -If there is a NULL age, that does not affect the average. (AVG() ignores NULLs.) However, this "rule" only applies to aggregate functions. but aggregate functions are indistinguishable from standard, value-altering functions: +If there is a NULL age, that does not affect the average. (AVG() ignores NULLs.) However, this "rule" only applies to aggregate functions. But aggregate functions are indistinguishable from standard, value-altering functions: ``` SELECT ABS(age) FROM citizen; @@ -486,7 +485,7 @@ The relational algebra neither requires nor recommends SQL ternary logic with NU ### Sets Can Be Empty -A relation as defined by the relational algebra is set of attributes (called the "header") and a set of tuples (the "body") with data and matching attributes. Therefore, empty sets for both attributes and/or the tuple set are valid and meaningful. Empty tuple sets are obviously useful for representing a starting state (we don't know anything yet), but is there a value to supporting an empty attribute set such as with a table with zero columns? +A relation as defined by the relational algebra is a set of attributes (called the "header") and a set of tuples (the "body") with data and matching attributes. Therefore, empty sets for both attributes and/or the tuple set are valid and meaningful. Empty tuple sets are obviously useful for representing a starting state (we don't know anything yet), but is there a value to supporting an empty attribute set such as with a table with zero columns? It's rare to see an empty attribute (column set) in SQL, but it is possible. @@ -764,7 +763,7 @@ SQLegacy (master/main): select status from s where city='London' order by status Note that SQLegacy always returns dataframes as indicated by "DF" in the top right of the diagram. That's because SQLegacy supports post-processing relational expressions into dataframes which do support ordering. SQL results are always ordered, even when arbitrarily. -The SQLegacy dialect and TutorialD implementations can co-exist and execute queries on the same databases. Since the Project:M36 software is built on the relational algebra on not SQL, other DBMS languages could be added, too. +The SQLegacy dialect and TutorialD implementations can co-exist and execute queries on the same databases. Since the Project:M36 software is built on the relational algebra and not on SQL, other DBMS languages could be added, too. Relying on the relational algebra simply opens more doors for correctness, cohesiveness, productivity, optimizations, and more. From b82b9f2a18b03ae17d66cf3d0922ebb752c80cab Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 8 Jul 2024 15:06:33 -0400 Subject: [PATCH 141/170] wip "sum" working but API disappointing --- project-m36.cabal | 2 + src/bin/TutorialD/Interpreter/Base.hs | 1 - .../TutorialD/Interpreter/RelationalExpr.hs | 44 ++++++++++--- src/bin/TutorialD/Interpreter/Types.hs | 11 +++- src/bin/TutorialD/Printer.hs | 2 + src/lib/ProjectM36/AggregateFunctions.hs | 26 ++++++++ .../ProjectM36/AggregateFunctions/Basic.hs | 31 ++++++++++ src/lib/ProjectM36/AtomFunctionError.hs | 4 +- src/lib/ProjectM36/AtomFunctions/Primitive.hs | 8 ++- src/lib/ProjectM36/Base.hs | 31 +++++++++- src/lib/ProjectM36/DatabaseContext.hs | 3 + src/lib/ProjectM36/FunctionalDependency.hs | 2 +- src/lib/ProjectM36/HashSecurely.hs | 2 + src/lib/ProjectM36/NormalizeExpr.hs | 6 +- .../ProjectM36/ReferencedTransactionIds.hs | 2 + src/lib/ProjectM36/RelationalExpression.hs | 38 +++++++++++- src/lib/ProjectM36/SQL/Convert.hs | 61 ++++++++++--------- src/lib/ProjectM36/Shortcuts.hs | 4 +- src/lib/ProjectM36/StaticOptimizer.hs | 1 + .../TransGraphRelationalExpression.hs | 2 + src/lib/ProjectM36/Transaction/Persist.hs | 15 ++++- src/lib/ProjectM36/TransactionGraph.hs | 4 +- src/lib/ProjectM36/TransactionGraph/Merge.hs | 7 +++ src/lib/ProjectM36/WithNameExpr.hs | 6 +- 24 files changed, 258 insertions(+), 55 deletions(-) create mode 100644 src/lib/ProjectM36/AggregateFunctions.hs create mode 100644 src/lib/ProjectM36/AggregateFunctions/Basic.hs diff --git a/project-m36.cabal b/project-m36.cabal index e3d5a2cf..e52b2f73 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -64,6 +64,8 @@ Library ProjectM36.Atom, ProjectM36.AtomFunction, ProjectM36.AtomFunctionError, + ProjectM36.AggregateFunctions, + ProjectM36.AggregateFunctions.Basic, ProjectM36.ScriptSession, ProjectM36.Shortcuts, ProjectM36.DatabaseContextFunction, diff --git a/src/bin/TutorialD/Interpreter/Base.hs b/src/bin/TutorialD/Interpreter/Base.hs index b2b7a591..1a1d16c9 100644 --- a/src/bin/TutorialD/Interpreter/Base.hs +++ b/src/bin/TutorialD/Interpreter/Base.hs @@ -72,7 +72,6 @@ identifier = do identifierRemainder :: Char -> Parser Text identifierRemainder c = do rest <- many (alphaNumChar <|> char '_' <|> char '#') - spaceConsumer pure (pack (c:rest)) symbol :: ParseStr -> Parser Text diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs index 1df0f43c..ba86b93b 100644 --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -15,6 +15,7 @@ import qualified Data.Set as S import qualified Data.Map as M import Data.List (sort) import ProjectM36.MiscUtils +import Control.Monad (void) --used in projection attributeListP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a) @@ -207,14 +208,16 @@ atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) atomExprP = consumeAtomExprP True consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a) -consumeAtomExprP consume = try functionAtomExprP <|> - ifThenAtomExprP <|> - boolAtomExprP <|> -- we do this before the constructed atom parser to consume True and False - try (parens (constructedAtomExprP True)) <|> - constructedAtomExprP consume <|> - relationalAtomExprP <|> - attributeAtomExprP <|> - try nakedAtomExprP +consumeAtomExprP consume = + try aggregateFunctionAtomExprP <|> + try functionAtomExprP <|> + ifThenAtomExprP <|> + boolAtomExprP <|> -- we do this before the constructed atom parser to consume True and False + try (parens (constructedAtomExprP True)) <|> + constructedAtomExprP consume <|> + relationalAtomExprP <|> + attributeAtomExprP <|> + try nakedAtomExprP attributeAtomExprP :: Parser (AtomExprBase a) attributeAtomExprP = do @@ -247,6 +250,29 @@ ifThenAtomExprP = do reserved "else" IfThenAtomExpr ifE thenE <$> atomExprP + +-- "@relattr.subrelattr" +subrelationAttributeNameP :: Parser (AttributeName, AttributeName) +subrelationAttributeNameP = do + void $ single '@' + relAttr <- uncapitalizedOrQuotedIdentifier + void $ single '.' + subrelAttr <- uncapitalizedOrQuotedIdentifier + spaceConsumer + pure (relAttr, subrelAttr) + +aggregateFunctionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) +aggregateFunctionAtomExprP = do + fname <- functionNameP + parens $ do + aggInfo <- subrelationAttributeNameP + args <- try (do + void comma + sepBy atomExprP comma) + <|> pure [] + AggregateFunctionAtomExpr fname aggInfo args <$> parseMarkerP + + functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) functionAtomExprP = FunctionAtomExpr <$> functionNameP <*> parens (sepBy atomExprP comma) <*> parseMarkerP @@ -291,7 +317,7 @@ withMacroExprP = do createMacroP :: RelationalMarkerExpr a => Parser (WithNameExprBase a, RelationalExprBase a) createMacroP = do - name <- identifier + name <- identifier <* spaceConsumer reservedOp "as" expr <- relExprP marker <- parseMarkerP diff --git a/src/bin/TutorialD/Interpreter/Types.hs b/src/bin/TutorialD/Interpreter/Types.hs index 50378d1f..fcb6acdd 100644 --- a/src/bin/TutorialD/Interpreter/Types.hs +++ b/src/bin/TutorialD/Interpreter/Types.hs @@ -22,10 +22,15 @@ dataConstructorNameP = try $ do pure ident attributeNameP :: Parser AttributeName -attributeNameP = try uncapitalizedIdentifier <|> quotedIdentifier +attributeNameP = uncapitalizedOrQuotedIdentifier <* spaceConsumer functionNameP :: Parser FunctionName -functionNameP = try uncapitalizedIdentifier <|> quotedIdentifier +functionNameP = uncapitalizedOrQuotedIdentifier <* spaceConsumer + +-- does not consumer following spaces +uncapitalizedOrQuotedIdentifier :: Parser StringType +uncapitalizedOrQuotedIdentifier = + try uncapitalizedIdentifier <|> quotedIdentifier -- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments. -- data *Either a b* = Left a | Right b @@ -75,4 +80,4 @@ monoTypeConstructorP = ADTypeConstructor <$> typeConstructorNameP <*> pure [] <| relVarNameP :: Parser RelVarName -relVarNameP = try uncapitalizedIdentifier <|> quotedIdentifier +relVarNameP = uncapitalizedOrQuotedIdentifier <* spaceConsumer diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index 552b90ea..202ea844 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -46,6 +46,8 @@ instance Pretty AtomExpr where pretty (AttributeAtomExpr attrName) = prettyAttributeName ("@" <> attrName) pretty (NakedAtomExpr atom) = pretty atom pretty (FunctionAtomExpr atomFuncName' atomExprs _) = pretty atomFuncName' <> prettyAtomExprsAsArguments atomExprs + pretty (AggregateFunctionAtomExpr atomFuncName' aggInfo atomExprs _) = + pretty atomFuncName' <> error "unimplemented" pretty (RelationAtomExpr relExpr) = pretty relExpr pretty (IfThenAtomExpr ifE thenE elseE) = "if" <+> pretty ifE <+> "then" <+> pretty thenE <+> "else" <+> pretty elseE pretty (ConstructedAtomExpr dName [] _) = pretty dName diff --git a/src/lib/ProjectM36/AggregateFunctions.hs b/src/lib/ProjectM36/AggregateFunctions.hs new file mode 100644 index 00000000..b4208714 --- /dev/null +++ b/src/lib/ProjectM36/AggregateFunctions.hs @@ -0,0 +1,26 @@ +module ProjectM36.AggregateFunctions where +import ProjectM36.Base +import ProjectM36.Error +import ProjectM36.Relation +import ProjectM36.AtomFunctionError +import qualified Data.HashSet as HS + +functionForName :: FunctionName -> AggregateFunctions -> Either RelationalError AggregateFunction +functionForName fname aggFuncs = + if HS.null foundFunc then + Left $ NoSuchFunctionError fname + else + Right $ head $ HS.toList foundFunc + where + foundFunc = HS.filter (\f -> aggFuncName f == fname) aggFuncs + +evalAggregateFunction :: AggregateFunctionBodyType -> AttributeName -> Atom -> [Atom] -> Relation -> Either AtomFunctionError Atom +evalAggregateFunction foldFunc attrInTuple startVal foldFuncArgs rel = + relFold tupFolder (Right startVal) rel + where + tupFolder :: RelationTuple -> Either AtomFunctionError Atom -> Either AtomFunctionError Atom + tupFolder tup (Right acc) = + case foldFunc tup attrInTuple acc foldFuncArgs of + Left err -> Left err + Right acc' -> Right acc' + tupFolder _tup e@Left{} = e diff --git a/src/lib/ProjectM36/AggregateFunctions/Basic.hs b/src/lib/ProjectM36/AggregateFunctions/Basic.hs new file mode 100644 index 00000000..a52420ad --- /dev/null +++ b/src/lib/ProjectM36/AggregateFunctions/Basic.hs @@ -0,0 +1,31 @@ +module ProjectM36.AggregateFunctions.Basic where +import ProjectM36.Base +import ProjectM36.Tuple +import ProjectM36.AtomFunctionError +import qualified Data.HashSet as HS + +-- count, sum, max, min +basicAggregateFunctions :: AggregateFunctions +basicAggregateFunctions = HS.fromList + [ +{- AggregateFunction { aggFuncName = "count", + aggFuncFoldFunc = (\_ _ rel -> + case cardinality rel of + Finite i -> pure (IntegerAtom (fromIntegral i)) + Countable -> Left InvalidIntBoundError), + aggFuncAccumType = IntegerAtomType + },-} + AggregateFunction { aggFuncName = "sum", + aggFuncFoldFunc = sumFold, + aggFuncFoldType = [IntegerAtomType], + aggFuncAccumType = IntegerAtomType + } + ] + +sumFold :: AggregateFunctionBodyType +sumFold tup attrName (IntegerAtom acc) [] = + case atomForAttributeName attrName tup of + Right (IntegerAtom i) -> pure (IntegerAtom (acc + i)) + Right _ -> Left AtomFunctionTypeMismatchError + Left _ -> Left (AtomFunctionAttributeNameNotFoundError attrName) +sumFold _ _ _ _ = Left AtomFunctionTypeMismatchError diff --git a/src/lib/ProjectM36/AtomFunctionError.hs b/src/lib/ProjectM36/AtomFunctionError.hs index 3fd7ea5b..9cda406d 100644 --- a/src/lib/ProjectM36/AtomFunctionError.hs +++ b/src/lib/ProjectM36/AtomFunctionError.hs @@ -9,11 +9,13 @@ data AtomFunctionError = AtomFunctionUserError String | AtomFunctionParseError String | InvalidIntervalOrderingError | InvalidIntervalBoundariesError | + AtomFunctionAttributeNameNotFoundError Text | InvalidIntBoundError | InvalidUUIDString Text | + RelationAtomExpectedError Text | AtomFunctionEmptyRelationError | AtomTypeDoesNotSupportOrderingError Text | AtomTypeDoesNotSupportIntervalError Text | AtomFunctionBytesDecodingError String - deriving(Generic, Eq, Show, NFData) + deriving (Generic, Eq, Show, NFData) diff --git a/src/lib/ProjectM36/AtomFunctions/Primitive.hs b/src/lib/ProjectM36/AtomFunctions/Primitive.hs index 1d37476b..8a020e16 100644 --- a/src/lib/ProjectM36/AtomFunctions/Primitive.hs +++ b/src/lib/ProjectM36/AtomFunctions/Primitive.hs @@ -33,7 +33,7 @@ primitiveAtomFunctions = HS.fromList [ x:_ -> pure x _ -> Left AtomFunctionTypeMismatchError )}, - Function { funcName = "sum", + Function { funcName = "sum_agg", funcType = foldAtomFuncType IntegerAtomType IntegerAtomType, funcBody = body $ relationAtomFunc relationSum }, @@ -117,6 +117,12 @@ primitiveAtomFunctions = HS.fromList [ [BoolAtom b1, BoolAtom b2] -> Right $ BoolAtom (b1 || b2) _ -> Left AtomFunctionTypeMismatchError + }, + Function { funcName = "increment", + funcType = [IntegerAtomType, IntegerAtomType], + funcBody = body $ \case + [IntegerAtom i] -> pure (IntegerAtom (i+1)) + _ -> Left AtomFunctionTypeMismatchError } ] <> scientificAtomFunctions diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index bcd2d261..637d63bc 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -357,6 +357,7 @@ data DatabaseContext = DatabaseContext { relationVariables :: RelationVariables, atomFunctions :: AtomFunctions, dbcFunctions :: DatabaseContextFunctions, + aggregateFunctions :: AggregateFunctions, notifications :: Notifications, typeConstructorMapping :: TypeConstructorMapping, registeredQueries :: RegisteredQueries @@ -504,13 +505,15 @@ instance Hashable AtomExpr type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker -type AggAtomFuncExprInfo = Maybe AttributeName +type AggAtomFuncExprInfo = (AttributeName, AttributeName) -- (relvar attribute name, subrel attribute name) -- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple. data AtomExprBase a = AttributeAtomExpr AttributeName | + SubRelationTupleProjectionAtomExpr AttributeName AttributeName | --used by aggregate/fold functions such as "sum" NakedAtomExpr !Atom | - FunctionAtomExpr !FunctionName [AtomExprBase a] AggAtomFuncExprInfo a | + FunctionAtomExpr !FunctionName [AtomExprBase a] a | -- as a simple, first aggregation case, we can only apply an aggregation to a RelationAtom while "selecting" one attribute + AggregateFunctionAtomExpr !FunctionName AggAtomFuncExprInfo [AtomExprBase a] a | RelationAtomExpr (RelationalExprBase a) | IfThenAtomExpr (AtomExprBase a) (AtomExprBase a) (AtomExprBase a) | -- if, then, else ConstructedAtomExpr DataConstructorName [AtomExprBase a] a @@ -643,6 +646,30 @@ type AtomFunctionBody = FunctionBody AtomFunctionBodyType type DatabaseContextFunction = Function DatabaseContextFunctionBodyType type DatabaseContextFunctionBody = FunctionBody DatabaseContextFunctionBodyType +type AggregateFunctions = HS.HashSet AggregateFunction +type AggregateFunctionBodyType = + RelationTuple -> -- ^ tuple inside the relation-valued attribute + AttributeName -> -- ^ the attribute of the RVA- in the future, this could be other projections on the tuple or perhaps a scalar expression + Atom -> -- ^ fold accumulator + [Atom] -> -- ^ other, static arguments + Either AtomFunctionError Atom + +-- functions to be run on sub-relations- they can be built up from AtomFunctions +data AggregateFunction = + AggregateFunction { + aggFuncName :: FunctionName, + aggFuncFoldFunc :: AggregateFunctionBodyType, + aggFuncFoldType :: [AtomType], + aggFuncAccumType :: AtomType + } + deriving (Generic, NFData) + +instance Hashable AggregateFunction where + hashWithSalt salt func = salt `hashWithSalt` aggFuncName func `hashWithSalt` aggFuncAccumType func + +instance Eq AggregateFunction where + a == b = aggFuncName a == aggFuncName b + attrTypeVars :: Attribute -> S.Set TypeVarName attrTypeVars (Attribute _ aType) = case aType of IntAtomType -> S.empty diff --git a/src/lib/ProjectM36/DatabaseContext.hs b/src/lib/ProjectM36/DatabaseContext.hs index 6896f90d..d64adfa9 100644 --- a/src/lib/ProjectM36/DatabaseContext.hs +++ b/src/lib/ProjectM36/DatabaseContext.hs @@ -8,6 +8,7 @@ import ProjectM36.DataTypes.Basic import ProjectM36.AtomFunctions.Basic import ProjectM36.Relation import ProjectM36.DatabaseContextFunction +import ProjectM36.AggregateFunctions.Basic empty :: DatabaseContext empty = DatabaseContext { inclusionDependencies = M.empty, @@ -15,6 +16,7 @@ empty = DatabaseContext { inclusionDependencies = M.empty, notifications = M.empty, atomFunctions = HS.empty, dbcFunctions = HS.empty, + aggregateFunctions = HS.empty, typeConstructorMapping = mempty, registeredQueries = mempty } @@ -38,6 +40,7 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty, ("false", ExistingRelation relationFalse)], atomFunctions = basicAtomFunctions, dbcFunctions = basicDatabaseContextFunctions, + aggregateFunctions = basicAggregateFunctions, notifications = M.empty, typeConstructorMapping = basicTypeConstructorMapping, registeredQueries = M.singleton "booleans" (Union (RelationVariable "true" ()) (RelationVariable "false" ())) diff --git a/src/lib/ProjectM36/FunctionalDependency.hs b/src/lib/ProjectM36/FunctionalDependency.hs index 7383591c..73541c4c 100644 --- a/src/lib/ProjectM36/FunctionalDependency.hs +++ b/src/lib/ProjectM36/FunctionalDependency.hs @@ -17,4 +17,4 @@ inclusionDependenciesForFunctionalDependency (FunctionalDependency attrNamesSour zCount = FunctionAtomExpr "count" [AttributeAtomExpr "x"] () extendZName = Extend (AttributeExtendTupleExpr "z" zCount) relExprCount expr projectionAttrNames = projectZName (extendZName - (Group projectionAttrNames "x" (Project projectionAttrNames expr))) \ No newline at end of file + (Group projectionAttrNames "x" (Project projectionAttrNames expr))) diff --git a/src/lib/ProjectM36/HashSecurely.hs b/src/lib/ProjectM36/HashSecurely.hs index 4f6f3c1e..9949e784 100644 --- a/src/lib/ProjectM36/HashSecurely.hs +++ b/src/lib/ProjectM36/HashSecurely.hs @@ -141,6 +141,8 @@ instance HashBytes a => HashBytes (AtomExprBase a) where (NakedAtomExpr a) -> hashBytesL ctx "NakedAtomExpr" [SHash a] (FunctionAtomExpr fname args marker) -> hashBytesL ctx "FunctionAtomExpr" $ [SHash fname, SHash marker] <> map SHash args + (AggregateFunctionAtomExpr fname aggInfo args marker) -> + hashBytesL ctx "AggregateFunctionAtomExpr" $ [SHash fname, SHash aggInfo, SHash marker] <> map SHash args (RelationAtomExpr r) -> hashBytesL ctx "RelationAtomExpr" [SHash r] (IfThenAtomExpr i t e) -> hashBytesL ctx "IfThenAtomExpr" [SHash i, SHash t, SHash e] (ConstructedAtomExpr dConsName args marker) -> diff --git a/src/lib/ProjectM36/NormalizeExpr.hs b/src/lib/ProjectM36/NormalizeExpr.hs index b20569f3..a7090333 100644 --- a/src/lib/ProjectM36/NormalizeExpr.hs +++ b/src/lib/ProjectM36/NormalizeExpr.hs @@ -113,8 +113,10 @@ processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = processAtomExpr :: AtomExpr -> ProcessExprM GraphRefAtomExpr processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom -processAtomExpr (FunctionAtomExpr fName atomExprs aggInfo ()) = - FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> pure aggInfo <*> askMarker +processAtomExpr (FunctionAtomExpr fName atomExprs ()) = + FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> askMarker +processAtomExpr (AggregateFunctionAtomExpr fName aggInfo args ()) = + AggregateFunctionAtomExpr fName aggInfo <$> mapM processAtomExpr args <*> askMarker processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr processAtomExpr (IfThenAtomExpr ifE thenE elseE) = IfThenAtomExpr <$> processAtomExpr ifE <*> processAtomExpr thenE <*> processAtomExpr elseE diff --git a/src/lib/ProjectM36/ReferencedTransactionIds.hs b/src/lib/ProjectM36/ReferencedTransactionIds.hs index 96eef90f..ebf5146f 100644 --- a/src/lib/ProjectM36/ReferencedTransactionIds.hs +++ b/src/lib/ProjectM36/ReferencedTransactionIds.hs @@ -98,6 +98,8 @@ instance ReferencedTransactionIds a => ReferencedTransactionIds (AtomExprBase a) NakedAtomExpr{} -> mempty FunctionAtomExpr _ args marker -> S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args)) + AggregateFunctionAtomExpr _fname _aggInfo args marker -> + S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args)) RelationAtomExpr rExpr -> referencedTransactionIds rExpr ConstructedAtomExpr _ args marker -> diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index 3f32c036..65ebad3a 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -18,6 +18,7 @@ import ProjectM36.DatabaseContextFunction import ProjectM36.Arbitrary import ProjectM36.GraphRefRelationalExpr import ProjectM36.Transaction +import ProjectM36.AggregateFunctions as Agg import qualified ProjectM36.Attribute as A import qualified Data.Map as M import qualified Data.HashSet as HS @@ -51,7 +52,7 @@ import Control.Exception import GHC.Paths #endif ---import Debug.Trace +import Debug.Trace data DatabaseContextExprDetails = CountUpdatedTuples @@ -870,6 +871,31 @@ evalGraphRefAtomExpr tupIn (AttributeAtomExpr attrName) = Left err -> throwError err evalGraphRefAtomExpr _ (NakedAtomExpr atom) = pure atom +-- first argumentr is starting value, second argument is relationatom +evalGraphRefAtomExpr tupIn (AggregateFunctionAtomExpr funcName' (rvAttrName, aggAttributeName) arguments tid) = do + argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments + context <- gfDatabaseContextForMarker tid + let aggFuncs = aggregateFunctions context + --atomFuncs = atomFunctions context + traceShowM ("evalGraphRef agg"::String, rvAttrName, aggAttributeName) + aggFunc <- lift $ except (Agg.functionForName funcName' aggFuncs) + let zippedArgs = zip (safeInit (aggFuncFoldType aggFunc)) argTypes + safeInit [] = [] -- different behavior from normal init + safeInit xs = init xs + mapM_ (\(expType, actType) -> + lift $ except (atomTypeVerify expType actType)) zippedArgs + evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments + let startingVal = head evaldArgs + case atomForAttributeName rvAttrName tupIn of + Left err -> throwError err + Right (RelationAtom rel) -> do + traceShowM ("evalGraphRefAtomExpr"::String, aggAttributeName) + case evalAggregateFunction (aggFuncFoldFunc aggFunc) aggAttributeName startingVal [] rel of + Left err -> throwError (AtomFunctionUserError err) + Right v -> do + traceShowM ("evalGraphRefAtomExpr2"::String, v) + pure v + Right _ -> throwError (AttributeIsNotRelationValuedError rvAttrName) evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName' arguments tid) = do argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments context <- gfDatabaseContextForMarker tid @@ -931,6 +957,12 @@ typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do Left err -> throwError err typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom) +typeForGraphRefAtomExpr attrs (AggregateFunctionAtomExpr funcName' aggInfo atomArgs transId) = do + context <- gfDatabaseContextForMarker transId + let aggFuncs = aggregateFunctions context + aggFunc <- lift $ except (Agg.functionForName funcName' aggFuncs) + let funcRetType = last (aggFuncFoldType aggFunc) + pure funcRetType typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName' atomArgs transId) = do funcs <- atomFunctions <$> gfDatabaseContextForMarker transId case atomFunctionForName funcName' funcs of @@ -992,6 +1024,8 @@ verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType = lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom) +verifyGraphRefAtomExprTypes relIn (AggregateFunctionAtomExpr funcName' aggInfo argExprs tid) expectedType = do + pure expectedType verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName' funcArgExprs tid) expectedType = do context <- gfDatabaseContextForMarker tid let functions = atomFunctions context @@ -1465,6 +1499,8 @@ instance ResolveGraphRefTransactionMarker GraphRefWithNameExpr where instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where resolve orig@AttributeAtomExpr{} = pure orig resolve orig@NakedAtomExpr{} = pure orig + resolve (AggregateFunctionAtomExpr nam aggInfo args marker) = + AggregateFunctionAtomExpr nam aggInfo <$> mapM resolve args <*> pure marker resolve (FunctionAtomExpr nam atomExprs marker) = FunctionAtomExpr nam <$> mapM resolve atomExprs <*> pure marker resolve (RelationAtomExpr expr) = RelationAtomExpr <$> resolve expr diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 5f506730..2195176e 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -555,7 +555,7 @@ convertProjection typeF selItems groupBys havingExpr = do (S.fromList (map fst (nonAggregates groupInfo)))) "_sql_aggregate" else pure id - let coalesceBoolF expr = FunctionAtomExpr "sql_coalesce_bool" [expr] () + let coalesceBoolF expr = func "sql_coalesce_bool" [expr] fGroupHavingExtend <- case havingRestriction groupInfo of Nothing -> pure id @@ -632,11 +632,14 @@ convertTableExpr typeF tExpr = do limit = limitClause tExpr } pure (dfExpr, columnMap) +func :: FunctionName -> [AtomExpr] -> AtomExpr +func fname args = FunctionAtomExpr fname args () + convertWhereClause :: TypeForRelExprF -> RestrictionExpr -> ConvertM RestrictionPredicateExpr convertWhereClause typeF (RestrictionExpr rexpr) = do let wrongType t = throwSQLE $ TypeMismatchError t BoolAtomType --must be boolean expression - coalesceBoolF expr = FunctionAtomExpr "sql_coalesce_bool" [expr] () - sqlEq l = FunctionAtomExpr "sql_equals" l () + coalesceBoolF expr = func "sql_coalesce_bool" [expr] + sqlEq l = func "sql_equals" l case rexpr of IntegerLiteral{} -> wrongType IntegerAtomType DoubleLiteral{} -> wrongType DoubleAtomType @@ -650,7 +653,7 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do BinaryOperator (Identifier colName) (OperatorName ["="]) exprMatch -> do --we don't know here if this results in a boolean expression, so we pass it down attrName <- attributeNameForColumnName colName expr' <- convertScalarExpr typeF exprMatch - pure (AtomExprPredicate (coalesceBoolF (FunctionAtomExpr "sql_equals" [AttributeAtomExpr attrName, expr'] ()))) + pure (AtomExprPredicate (coalesceBoolF (func "sql_equals" [AttributeAtomExpr attrName, expr']))) BinaryOperator exprA op exprB -> do a <- convertScalarExpr typeF exprA b <- convertScalarExpr typeF exprB @@ -658,7 +661,7 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do pure (AtomExprPredicate (coalesceBoolF (f [a,b]))) PostfixOperator expr (OperatorName ops) -> do expr' <- convertScalarExpr typeF expr - let isnull = AtomExprPredicate (coalesceBoolF (FunctionAtomExpr "sql_isnull" [expr'] ())) + let isnull = AtomExprPredicate (coalesceBoolF (func "sql_isnull" [expr'])) case ops of ["is", "null"] -> pure isnull @@ -673,7 +676,7 @@ convertWhereClause typeF (RestrictionExpr rexpr) = do let predExpr' = sqlEq [eqExpr, firstItem] folder predExpr'' sexprItem = do item <- convertScalarExpr typeF sexprItem - pure $ FunctionAtomExpr "sql_or" [sqlEq [eqExpr,item], predExpr''] () + pure $ func "sql_or" [sqlEq [eqExpr,item], predExpr''] res <- AtomExprPredicate . coalesceBoolF <$> foldM folder predExpr' matches case inOrNotIn of In -> pure res @@ -708,9 +711,9 @@ convertScalarExpr typeF expr = do f <- lookupOperator False op pure $ f [a,b] FunctionApplication funcName' fargs -> do - func <- lookupFunc funcName' + func' <- lookupFunc funcName' fargs' <- mapM (convertScalarExpr typeF) fargs - pure (func fargs') + pure (func' fargs') other -> throwSQLE $ NotSupportedError ("scalar expr: " <> T.pack (show other)) -- SQL conflates projection and extension so we use the SQL context name here @@ -736,19 +739,19 @@ convertProjectionScalarExpr typeF expr = do f <- lookupOperator False op pure $ f [a,b] FunctionApplication fname fargs -> do - func <- lookupFunc fname + func' <- lookupFunc fname -- as a special case, count(*) is valid, if non-sensical SQL, so handle it here fargs' <- if fname == FuncName ["count"] && fargs == [Identifier (ColumnProjectionName [Asterisk])] then pure [AttributeAtomExpr "_sql_aggregate"] else mapM (convertProjectionScalarExpr typeF) fargs - pure (func fargs') + pure (func' fargs') PrefixOperator op sexpr -> do - func <- lookupOperator True op + func' <- lookupOperator True op arg <- convertProjectionScalarExpr typeF sexpr - pure (func [arg]) + pure (func' [arg]) CaseExpr conditionals mElse -> do - let coalesceBoolF expr' = FunctionAtomExpr "sql_coalesce_bool" [expr'] () + let coalesceBoolF expr' = func "sql_coalesce_bool" [expr'] conditionals' <- mapM (\(ifExpr, thenExpr) -> do ifE <- coalesceBoolF <$> convertProjectionScalarExpr typeF ifExpr thenE <- convertProjectionScalarExpr typeF thenExpr @@ -932,7 +935,7 @@ joinTableRef typeF rvA (_c,tref) = do else new_name joinName = firstAvailableName (1::Int) allAttrs - extender = AttributeExtendTupleExpr joinName (FunctionAtomExpr "sql_coalesce_bool" [joinRe] ()) + extender = AttributeExtendTupleExpr joinName (func "sql_coalesce_bool" [joinRe]) --joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ())) joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (NakedAtomExpr (BoolAtom True))) projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName])) @@ -942,7 +945,7 @@ joinTableRef typeF rvA (_c,tref) = do lookupOperator :: Bool -> OperatorName -> ConvertM ([AtomExpr] -> AtomExpr) lookupOperator isPrefix op@(OperatorName nam) | isPrefix = do - let f n args = FunctionAtomExpr n args () + let f n args = func n args case nam of ["-"] -> pure $ f "sql_negate" _ -> throwSQLE $ NoSuchSQLOperatorError op @@ -960,7 +963,7 @@ lookupFunc qname = Just match -> pure match other -> throwSQLE $ NotSupportedError ("function name: " <> T.pack (show other)) where - f n args = FunctionAtomExpr n args () + f n args = func n args aggMapper (FuncName [nam], nam') = (nam, f nam') aggMapper (FuncName other,_) = error ("unexpected multi-component SQL aggregate function: " <> show other) sqlFuncs = [(">",f "sql_gt"), @@ -974,7 +977,7 @@ lookupFunc qname = ("and", f "sql_and"), ("or", f "sql_or"), ("abs", f "sql_abs") - ] <> map aggMapper aggregateFunctions + ] <> map aggMapper aggregateFunctionsMap -- | Used in join condition detection necessary for renames to enable natural joins. @@ -1083,6 +1086,8 @@ pushDownAttributeRename renameSet matchExpr targetExpr = x@AttributeAtomExpr{} -> x --potential rename x@NakedAtomExpr{} -> x FunctionAtomExpr fname args () -> FunctionAtomExpr fname (pushAtom <$> args) () + AggregateFunctionAtomExpr fname aggInfo args () -> + AggregateFunctionAtomExpr fname aggInfo (pushAtom <$> args) () --potential rename in aggInfo RelationAtomExpr e -> RelationAtomExpr (push e) IfThenAtomExpr ifE thenE elseE -> IfThenAtomExpr (pushAtom ifE) (pushAtom thenE) (pushAtom elseE) ConstructedAtomExpr dConsName args () -> ConstructedAtomExpr dConsName (pushAtom <$> args) () @@ -1300,7 +1305,7 @@ databaseContextExprForUniqueKeyWithNull rvname attrName = where incDep = inclusionDependencyForKey (AttributeNames (S.singleton attrName)) (Restrict notNull (RelationVariable rvname ())) incDepName = rvname <> "_" <> attrName <> "_unique" - notNull = NotPredicate (AtomExprPredicate (FunctionAtomExpr "sql_isnull" [AttributeAtomExpr attrName] ())) + notNull = NotPredicate (AtomExprPredicate (func "sql_isnull" [AttributeAtomExpr attrName] )) {- @@ -1389,14 +1394,14 @@ data GroupByInfo = emptyGroupByInfo :: GroupByInfo emptyGroupByInfo = GroupByInfo { aggregates = [], nonAggregates = [], havingRestriction = Nothing } -aggregateFunctions :: [(FuncName, FunctionName)] -aggregateFunctions = [(FuncName ["max"], "sql_max"), +aggregateFunctionsMap :: [(FuncName, FunctionName)] +aggregateFunctionsMap = [(FuncName ["max"], "sql_max"), (FuncName ["min"], "sql_min"), (FuncName ["sum"], "sql_sum"), (FuncName ["count"], "sql_count")] isAggregateFunction :: FuncName -> Bool -isAggregateFunction fname = fname `elem` map fst aggregateFunctions +isAggregateFunction fname = fname `elem` map fst aggregateFunctionsMap containsAggregate :: ProjectionScalarExpr -> Bool containsAggregate expr = @@ -1483,17 +1488,17 @@ processSQLAggregateFunctions expr = | fname == "sql_count" && -- count(*) counts the number of rows attrName == "_sql_aggregate" -> expr | fname == "sql_count" -> -- count(city) counts the number city elements that are not null - callF fname [RelationAtomExpr + func fname [RelationAtomExpr (Restrict (NotPredicate (AtomExprPredicate - (callF "sql_isnull" [AttributeAtomExpr attrName]))) (RelationValuedAttribute "_sql_aggregate"))] - | fname `elem` map snd aggregateFunctions -> - FunctionAtomExpr fname - [RelationAtomExpr (Project (AttributeNames (S.singleton attrName)) (RelationValuedAttribute "_sql_aggregate"))] () + (func "sql_isnull" [AttributeAtomExpr attrName]))) (RelationValuedAttribute "_sql_aggregate"))] + | fname `elem` map snd aggregateFunctionsMap -> + func fname + [RelationAtomExpr (Project (AttributeNames (S.singleton attrName)) (RelationValuedAttribute "_sql_aggregate"))] FunctionAtomExpr fname args () -> FunctionAtomExpr fname (map processSQLAggregateFunctions args) () + AggregateFunctionAtomExpr fname aggInfo args () -> + AggregateFunctionAtomExpr fname aggInfo (processSQLAggregateFunctions <$> args) () RelationAtomExpr{} -> expr --not supported in SQL IfThenAtomExpr ifE thenE elseE -> IfThenAtomExpr (processSQLAggregateFunctions ifE) (processSQLAggregateFunctions thenE) (processSQLAggregateFunctions elseE) ConstructedAtomExpr{} -> expr --not supported in SQL - where - callF fname args = FunctionAtomExpr fname args () diff --git a/src/lib/ProjectM36/Shortcuts.hs b/src/lib/ProjectM36/Shortcuts.hs index fd883179..048bad64 100644 --- a/src/lib/ProjectM36/Shortcuts.hs +++ b/src/lib/ProjectM36/Shortcuts.hs @@ -81,7 +81,7 @@ instance (Convertible a AtomExpr, KnownSymbol x) => IsLabel x (a -> (AttributeNa -- -- This usage is not working in RestrictionPredicateExpr and AttributeExtendTupleExpr. Use f "a" [1] instead. instance (KnownSymbol x, Convertible a AtomExpr) => IsLabel x ([a] -> AtomExpr) where - fromLabel = \as' -> FunctionAtomExpr name (map convert as') Nothing () + fromLabel = \as' -> FunctionAtomExpr name (map convert as') () where name = T.pack $ symbolVal @x Proxy instance (KnownSymbol x) => IsLabel x AtomExpr where @@ -175,7 +175,7 @@ instance Convertible RelVarName RelationalExpr where -- works in RestrictedPredicateExpr and AttributeExtendTupleExpr -- usage: f "gte" [1] f :: Convertible a AtomExpr => FunctionName -> [a] -> AtomExpr -f n as' = FunctionAtomExpr n (map convert as') Nothing () +f n as' = FunctionAtomExpr n (map convert as') () -- DatabaseContextExpr -- define diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index ecbf3399..b4ec9bf4 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -440,6 +440,7 @@ isStaticAtomExpr NakedAtomExpr{} = True isStaticAtomExpr ConstructedAtomExpr{} = True isStaticAtomExpr AttributeAtomExpr{} = False isStaticAtomExpr FunctionAtomExpr{} = False +isStaticAtomExpr AggregateFunctionAtomExpr{} = False isStaticAtomExpr IfThenAtomExpr{} = False isStaticAtomExpr RelationAtomExpr{} = False diff --git a/src/lib/ProjectM36/TransGraphRelationalExpression.hs b/src/lib/ProjectM36/TransGraphRelationalExpression.hs index dd5c8544..c7010d45 100644 --- a/src/lib/ProjectM36/TransGraphRelationalExpression.hs +++ b/src/lib/ProjectM36/TransGraphRelationalExpression.hs @@ -125,6 +125,8 @@ processTransGraphAtomExpr (AttributeAtomExpr aname) = pure $ AttributeAtomExpr a processTransGraphAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom processTransGraphAtomExpr (FunctionAtomExpr funcName' args tLookup) = FunctionAtomExpr funcName' <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup +processTransGraphAtomExpr (AggregateFunctionAtomExpr funcName' aggInfo args tLookup) = + AggregateFunctionAtomExpr funcName' aggInfo <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup processTransGraphAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processTransGraphRelationalExpr expr processTransGraphAtomExpr (IfThenAtomExpr ifE thenE elseE) = diff --git a/src/lib/ProjectM36/Transaction/Persist.hs b/src/lib/ProjectM36/Transaction/Persist.hs index bdc12063..4b9c1c6c 100644 --- a/src/lib/ProjectM36/Transaction/Persist.hs +++ b/src/lib/ProjectM36/Transaction/Persist.hs @@ -12,6 +12,7 @@ import ProjectM36.Error import ProjectM36.Transaction import ProjectM36.DatabaseContextFunction import ProjectM36.AtomFunction +import ProjectM36.AggregateFunctions.Basic import ProjectM36.Persist (DiskSync, renameSync, writeSerialiseSync) import ProjectM36.Function import qualified Data.Map as M @@ -69,6 +70,9 @@ subschemasPath transdir = transdir "schemas" registeredQueriesPath :: FilePath -> FilePath registeredQueriesPath transdir = transdir "registered_queries" +aggregateFunctionsPath :: FilePath -> FilePath +aggregateFunctionsPath transdir = transdir "aggregateFunctions" + -- | where compiled modules are stored within the database directory objectFilesPath :: FilePath -> FilePath objectFilesPath transdir = transdir ".." "compiled_modules" @@ -88,12 +92,15 @@ readTransaction dbdir transId mScriptSession = do notifs <- readNotifications transDir dbcFuncs <- readFuncs transDir (dbcFuncsPath transDir) basicDatabaseContextFunctions mScriptSession atomFuncs <- readFuncs transDir (atomFuncsPath transDir) precompiledAtomFunctions mScriptSession +-- aggFuncs <- readAggFuncs transDir + let aggFuncs = basicAggregateFunctions registeredQs <- readRegisteredQueries transDir let newContext = DatabaseContext { inclusionDependencies = incDeps, relationVariables = relvars, typeConstructorMapping = typeCons, notifications = notifs, - atomFunctions = atomFuncs, + atomFunctions = atomFuncs, + aggregateFunctions = aggFuncs, dbcFunctions = dbcFuncs, registeredQueries = registeredQs } newSchemas = Schemas newContext sschemas @@ -281,6 +288,12 @@ readRegisteredQueries transDir = do let regQsPath = registeredQueriesPath transDir readFileDeserialise regQsPath +{- +readAggFuncs :: FilePath -> IO AggregateFunctions +readAggFuncs transDir = do + let aggFuncsPath = aggregateFunctionsPath transDir + HS.fromList <$> readFileDeserialise aggFuncsPath +-} writeRegisteredQueries :: DiskSync -> FilePath -> RegisteredQueries -> IO () writeRegisteredQueries sync transDir regQs = do let regQsPath = registeredQueriesPath transDir diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs index 59135f10..9d3f9215 100644 --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -509,6 +509,7 @@ createUnionMergeTransaction stamp' newId strategy (t1,t2) = do incDeps <- liftMergeE $ unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB) relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB) atomFuncs <- liftMergeE $ unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB) + aggFuncs <- liftMergeE $ unionMergeAggregateFunctions preference (aggregateFunctions contextA) (aggregateFunctions contextB) notifs <- liftMergeE $ unionMergeMaps preference (notifications contextA) (notifications contextB) types <- liftMergeE $ unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB) dbcFuncs <- liftMergeE $ unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB) @@ -517,7 +518,8 @@ createUnionMergeTransaction stamp' newId strategy (t1,t2) = do let newContext = DatabaseContext { inclusionDependencies = incDeps, relationVariables = relVars, - atomFunctions = atomFuncs, + atomFunctions = atomFuncs, + aggregateFunctions = aggFuncs, dbcFunctions = dbcFuncs, notifications = notifs, typeConstructorMapping = types, diff --git a/src/lib/ProjectM36/TransactionGraph/Merge.hs b/src/lib/ProjectM36/TransactionGraph/Merge.hs index 5edad854..9f4d043b 100644 --- a/src/lib/ProjectM36/TransactionGraph/Merge.hs +++ b/src/lib/ProjectM36/TransactionGraph/Merge.hs @@ -62,6 +62,13 @@ unionMergeAtomFunctions prefer funcsA funcsB = case prefer of PreferFirst -> pure $ HS.union funcsA funcsB PreferSecond -> pure $ HS.union funcsB funcsA PreferNeither -> pure $ HS.union funcsA funcsB + +unionMergeAggregateFunctions :: MergePreference -> AggregateFunctions -> AggregateFunctions -> Either MergeError AggregateFunctions +unionMergeAggregateFunctions prefer funcsA funcsB = + case prefer of + PreferFirst -> pure $ HS.union funcsA funcsB + PreferSecond -> pure $ HS.union funcsB funcsA + PreferNeither -> pure $ HS.union funcsA funcsB unionMergeTypeConstructorMapping :: MergePreference -> TypeConstructorMapping -> TypeConstructorMapping -> Either MergeError TypeConstructorMapping unionMergeTypeConstructorMapping prefer typesA typesB = do diff --git a/src/lib/ProjectM36/WithNameExpr.hs b/src/lib/ProjectM36/WithNameExpr.hs index d45f1376..7f0cf0fb 100644 --- a/src/lib/ProjectM36/WithNameExpr.hs +++ b/src/lib/ProjectM36/WithNameExpr.hs @@ -85,8 +85,10 @@ substituteWithNameMacrosAtomExpr macros atomExpr = case atomExpr of e@AttributeAtomExpr{} -> e e@NakedAtomExpr{} -> e - FunctionAtomExpr fname atomExprs aggInfo tid -> - FunctionAtomExpr fname (map (substituteWithNameMacrosAtomExpr macros) atomExprs) aggInfo tid + FunctionAtomExpr fname atomExprs tid -> + FunctionAtomExpr fname (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid + AggregateFunctionAtomExpr fname aggInfo atomExprs tid -> + AggregateFunctionAtomExpr fname aggInfo (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid RelationAtomExpr reExpr -> RelationAtomExpr (substituteWithNameMacros macros reExpr) IfThenAtomExpr ifE thenE elseE -> From d201787fff8f43b893d7ccdc53345bf3bf2359f2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 10 Jul 2024 19:30:16 -0400 Subject: [PATCH 142/170] wip more subrelationfoldatom experimentation --- src/lib/ProjectM36/Arbitrary.hs | 12 +++++++++++- src/lib/ProjectM36/Atom.hs | 2 +- src/lib/ProjectM36/AtomType.hs | 1 + src/lib/ProjectM36/Atomable.hs | 2 ++ src/lib/ProjectM36/Base.hs | 6 +++++- src/lib/ProjectM36/DataTypes/Interval.hs | 2 ++ src/lib/ProjectM36/DataTypes/Primitive.hs | 1 + src/lib/ProjectM36/DataTypes/Sorting.hs | 2 ++ src/lib/ProjectM36/Relation/Parse/CSV.hs | 5 ++++- 9 files changed, 29 insertions(+), 4 deletions(-) diff --git a/src/lib/ProjectM36/Arbitrary.hs b/src/lib/ProjectM36/Arbitrary.hs index 340234cf..5e6c6bba 100644 --- a/src/lib/ProjectM36/Arbitrary.hs +++ b/src/lib/ProjectM36/Arbitrary.hs @@ -3,6 +3,7 @@ module ProjectM36.Arbitrary where import ProjectM36.Base +import qualified ProjectM36.Attribute as A import ProjectM36.Error import ProjectM36.AtomFunctionError import ProjectM36.AtomType @@ -28,12 +29,21 @@ arbitrary' ScientificAtomType = Right . ScientificAtom <$> lift (arbitrary :: Gen Scientific) arbitrary' (RelationAtomType attrs) = do - tcMap <-ask + tcMap <- ask maybeRel <- lift $ runReaderT (arbitraryRelation attrs (0,5)) tcMap case maybeRel of Left err -> pure $ Left err Right rel -> pure $ Right $ RelationAtom rel +arbitrary' (SubrelationFoldAtomType typ) = do + tcMap <- ask + maybeRel <- lift $ runReaderT (arbitraryRelation (A.attributesFromList [Attribute "a" typ]) (0,5)) tcMap + case maybeRel of + Left err -> pure $ Left err + Right rel -> do + anAttr <- lift $ elements (A.attributeNamesList (attributes rel)) + pure (Right (SubrelationFoldAtom rel anAttr)) + arbitrary' IntAtomType = Right . IntAtom <$> lift (arbitrary :: Gen Int) diff --git a/src/lib/ProjectM36/Atom.hs b/src/lib/ProjectM36/Atom.hs index ec0793b0..3e9b5f5c 100644 --- a/src/lib/ProjectM36/Atom.hs +++ b/src/lib/ProjectM36/Atom.hs @@ -23,7 +23,7 @@ atomToText (ByteStringAtom i) = (T.pack . show) i atomToText (BoolAtom i) = (T.pack . show) i atomToText (UUIDAtom u) = (T.pack . show) u atomToText (RelationalExprAtom re) = (T.pack . show) re - +atomToText (SubrelationFoldAtom rel attrName) = (T.pack . show) rel <> " @" <> attrName atomToText (RelationAtom i) = (T.pack . show) i atomToText (ConstructedAtom dConsName typ atoms) | isIntervalAtomType typ = case atoms of --special handling for printing intervals diff --git a/src/lib/ProjectM36/AtomType.hs b/src/lib/ProjectM36/AtomType.hs index 18664bbd..ef8f67d5 100644 --- a/src/lib/ProjectM36/AtomType.hs +++ b/src/lib/ProjectM36/AtomType.hs @@ -448,6 +448,7 @@ isResolvedType typ = RelationalExprAtomType -> True RelationAtomType attrs -> isResolvedAttributes attrs ConstructedAtomType _ tvMap -> all isResolvedType (M.elems tvMap) + SubrelationFoldAtomType typ' -> isResolvedType typ' TypeVariableType _ -> False isResolvedAttributes :: Attributes -> Bool diff --git a/src/lib/ProjectM36/Atomable.hs b/src/lib/ProjectM36/Atomable.hs index 78f84404..2500541d 100644 --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -256,6 +256,8 @@ typeToTypeConstructor (RelationAtomType attrs) = RelationAtomTypeConstructor $ map attrToAttrExpr $ V.toList (attributesVec attrs) where attrToAttrExpr (Attribute n t) = AttributeAndTypeNameExpr n (typeToTypeConstructor t) () +typeToTypeConstructor (SubrelationFoldAtomType _typ) = + error "typeToTypeConstructor for SubrelationFoldAtomType is nonsense" typeToTypeConstructor (ConstructedAtomType tcName tvMap) = ADTypeConstructor tcName $ map typeToTypeConstructor (M.elems tvMap) typeToTypeConstructor (TypeVariableType tvName) = TypeVariable tvName diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 637d63bc..9e1cf372 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -67,6 +67,7 @@ data Atom = IntegerAtom !Integer | UUIDAtom !UUID | RelationAtom !Relation | RelationalExprAtom !RelationalExpr | --used for returning inc deps + SubrelationFoldAtom !Relation !AttributeName | ConstructedAtom !DataConstructorName !AtomType [Atom] deriving (Eq, Show, Typeable, NFData, Generic, Read) @@ -85,6 +86,7 @@ instance Hashable Atom where hashWithSalt salt (UUIDAtom u) = salt `hashWithSalt` u hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r hashWithSalt salt (RelationalExprAtom re) = salt `hashWithSalt` re + hashWithSalt salt (SubrelationFoldAtom rel attrName) = salt `hashWithSalt` rel `hashWithSalt` attrName -- I suspect the definition of ConstructedAtomType with its name alone is insufficient to disambiguate the cases; for example, one could create a type named X, remove a type named X, and re-add it using different constructors. However, as long as requests are served from only one DatabaseContext at-a-time, the type name is unambiguous. This will become a problem for time-travel, however. -- | The AtomType uniquely identifies the type of a atom. @@ -99,6 +101,7 @@ data AtomType = IntAtomType | BoolAtomType | UUIDAtomType | RelationAtomType Attributes | + SubrelationFoldAtomType AtomType | ConstructedAtomType TypeConstructorName TypeVarMap | RelationalExprAtomType | TypeVariableType TypeVarName @@ -509,7 +512,6 @@ type AggAtomFuncExprInfo = (AttributeName, AttributeName) -- (relvar attribute n -- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple. data AtomExprBase a = AttributeAtomExpr AttributeName | - SubRelationTupleProjectionAtomExpr AttributeName AttributeName | --used by aggregate/fold functions such as "sum" NakedAtomExpr !Atom | FunctionAtomExpr !FunctionName [AtomExprBase a] a | -- as a simple, first aggregation case, we can only apply an aggregation to a RelationAtom while "selecting" one attribute @@ -683,6 +685,7 @@ attrTypeVars (Attribute _ aType) = case aType of BoolAtomType -> S.empty UUIDAtomType -> S.empty RelationalExprAtomType -> S.empty + SubrelationFoldAtomType{} -> S.empty (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList (attributesVec attrs))) (ConstructedAtomType _ tvMap) -> M.keysSet tvMap (TypeVariableType nam) -> S.singleton nam @@ -709,6 +712,7 @@ atomTypeVars ByteStringAtomType = S.empty atomTypeVars BoolAtomType = S.empty atomTypeVars UUIDAtomType = S.empty atomTypeVars RelationalExprAtomType = S.empty +atomTypeVars SubrelationFoldAtomType{} = S.empty atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList (attributesVec attrs))) atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap atomTypeVars (TypeVariableType nam) = S.singleton nam diff --git a/src/lib/ProjectM36/DataTypes/Interval.hs b/src/lib/ProjectM36/DataTypes/Interval.hs index 2e25885a..05d362d1 100644 --- a/src/lib/ProjectM36/DataTypes/Interval.hs +++ b/src/lib/ProjectM36/DataTypes/Interval.hs @@ -40,6 +40,7 @@ supportsInterval typ = case typ of RelationAtomType _ -> False ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this RelationalExprAtomType -> False + SubrelationFoldAtomType{} -> False TypeVariableType _ -> False supportsOrdering :: AtomType -> Bool @@ -56,6 +57,7 @@ supportsOrdering typ = case typ of UUIDAtomType -> False RelationAtomType _ -> False RelationalExprAtomType -> False + SubrelationFoldAtomType{} -> False ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this TypeVariableType _ -> False diff --git a/src/lib/ProjectM36/DataTypes/Primitive.hs b/src/lib/ProjectM36/DataTypes/Primitive.hs index 4d3b1621..d87f3eb8 100644 --- a/src/lib/ProjectM36/DataTypes/Primitive.hs +++ b/src/lib/ProjectM36/DataTypes/Primitive.hs @@ -51,3 +51,4 @@ atomTypeForAtom (UUIDAtom _) = UUIDAtomType atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs atomTypeForAtom (ConstructedAtom _ aType _) = aType atomTypeForAtom (RelationalExprAtom _) = RelationalExprAtomType +atomTypeForAtom (SubrelationFoldAtom _ _) = SubrelationFoldAtomType (TypeVariableType "a") diff --git a/src/lib/ProjectM36/DataTypes/Sorting.hs b/src/lib/ProjectM36/DataTypes/Sorting.hs index dfab4671..bf07c7c4 100644 --- a/src/lib/ProjectM36/DataTypes/Sorting.hs +++ b/src/lib/ProjectM36/DataTypes/Sorting.hs @@ -30,6 +30,8 @@ isSortableAtomType typ = case typ of UUIDAtomType -> False RelationalExprAtomType -> False RelationAtomType _ -> False + SubrelationFoldAtomType{} -> False ConstructedAtomType _ _ -> False TypeVariableType _ -> False + diff --git a/src/lib/ProjectM36/Relation/Parse/CSV.hs b/src/lib/ProjectM36/Relation/Parse/CSV.hs index 93c83525..894cfb36 100644 --- a/src/lib/ProjectM36/Relation/Parse/CSV.hs +++ b/src/lib/ProjectM36/Relation/Parse/CSV.hs @@ -134,7 +134,10 @@ parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) takeToEndOfDat case lefts atomArgs of [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs))) errs -> pure (Left (someErrors errs)) -parseCSVAtomP attrName _ (RelationAtomType _) _ = pure (Left (RelationValuedAttributesNotSupportedError [attrName])) +parseCSVAtomP attrName _ (RelationAtomType _) _ = + pure (Left (RelationValuedAttributesNotSupportedError [attrName])) +parseCSVAtomP attrName _ (SubrelationFoldAtomType _) _ = + pure (Left (RelationValuedAttributesNotSupportedError [attrName])) parseCSVAtomP _ _ (TypeVariableType x) _ = pure (Left (TypeConstructorTypeVarMissing x)) capitalizedIdentifier :: APT.Parser T.Text From c2731c4e973c5148b267aeb3d3a852c513cf9198 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 14 Jul 2024 02:08:53 -0400 Subject: [PATCH 143/170] tests pass checkpoint new feature: sub-relation attribute aggregation expressions --- project-m36.cabal | 2 - src/bin/TutorialD/Interpreter/Base.hs | 3 + .../Interpreter/DatabaseContextExpr.hs | 14 ++-- .../Interpreter/DatabaseContextIOOperator.hs | 2 +- .../Interpreter/Import/BasicExamples.hs | 2 +- src/bin/TutorialD/Interpreter/Import/CSV.hs | 2 +- .../Interpreter/RODatabaseContextOperator.hs | 4 +- .../TutorialD/Interpreter/RelationalExpr.hs | 23 +++---- .../TutorialD/Interpreter/SchemaOperator.hs | 4 +- .../TransGraphRelationalOperator.hs | 2 +- .../Interpreter/TransactionGraphOperator.hs | 14 ++-- src/bin/TutorialD/Interpreter/Types.hs | 8 +-- src/bin/TutorialD/Printer.hs | 7 +- src/lib/ProjectM36/AggregateFunctions.hs | 26 ------- .../ProjectM36/AggregateFunctions/Basic.hs | 31 --------- src/lib/ProjectM36/AtomFunction.hs | 4 +- src/lib/ProjectM36/AtomFunctions/Primitive.hs | 58 ++++++++++------ src/lib/ProjectM36/AtomType.hs | 6 +- src/lib/ProjectM36/Base.hs | 27 +------- src/lib/ProjectM36/DataTypes/SQL/Null.hs | 8 ++- src/lib/ProjectM36/DatabaseContext.hs | 3 - src/lib/ProjectM36/HashSecurely.hs | 5 +- src/lib/ProjectM36/NormalizeExpr.hs | 3 +- .../ProjectM36/ReferencedTransactionIds.hs | 3 +- src/lib/ProjectM36/RelationalExpression.hs | 68 ++++++++----------- src/lib/ProjectM36/SQL/Convert.hs | 14 ++-- src/lib/ProjectM36/StaticOptimizer.hs | 2 +- .../TransGraphRelationalExpression.hs | 3 +- src/lib/ProjectM36/Transaction/Persist.hs | 10 --- src/lib/ProjectM36/TransactionGraph.hs | 2 - src/lib/ProjectM36/TransactionGraph/Merge.hs | 7 -- src/lib/ProjectM36/Tuple.hs | 1 - src/lib/ProjectM36/WithNameExpr.hs | 3 +- test/SQL/InterpreterTest.hs | 19 +++--- test/TutorialD/InterpreterTest.hs | 22 ++++-- 35 files changed, 162 insertions(+), 250 deletions(-) delete mode 100644 src/lib/ProjectM36/AggregateFunctions.hs delete mode 100644 src/lib/ProjectM36/AggregateFunctions/Basic.hs diff --git a/project-m36.cabal b/project-m36.cabal index e52b2f73..e3d5a2cf 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -64,8 +64,6 @@ Library ProjectM36.Atom, ProjectM36.AtomFunction, ProjectM36.AtomFunctionError, - ProjectM36.AggregateFunctions, - ProjectM36.AggregateFunctions.Basic, ProjectM36.ScriptSession, ProjectM36.Shortcuts, ProjectM36.DatabaseContextFunction, diff --git a/src/bin/TutorialD/Interpreter/Base.hs b/src/bin/TutorialD/Interpreter/Base.hs index 1a1d16c9..a99f4425 100644 --- a/src/bin/TutorialD/Interpreter/Base.hs +++ b/src/bin/TutorialD/Interpreter/Base.hs @@ -69,6 +69,9 @@ identifier = do istart <- letterChar <|> char '_' identifierRemainder istart +identifierP :: Parser Text +identifierP = identifier <* spaceConsumer + identifierRemainder :: Char -> Parser Text identifierRemainder c = do rest <- many (alphaNumChar <|> char '_' <|> char '#') diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs index 16dd464f..da325d04 100644 --- a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs @@ -98,7 +98,7 @@ data IncDepOp = SubsetOp | EqualityOp addConstraintP :: Parser DatabaseContextExpr addConstraintP = do reservedOp "constraint" <|> reservedOp "foreign key" - constraintName <- identifier + constraintName <- identifierP subset <- relExprP op <- (reservedOp "in" $> SubsetOp) <|> (reservedOp "equals" $> EqualityOp) superset <- relExprP @@ -112,13 +112,13 @@ addConstraintP = do deleteConstraintP :: Parser DatabaseContextExpr deleteConstraintP = do reserved "deleteconstraint" - RemoveInclusionDependency <$> identifier + RemoveInclusionDependency <$> identifierP -- key {} keyP :: Parser DatabaseContextExpr keyP = do reserved "key" - keyName <- identifier + keyName <- identifierP uniquenessAttrNames <- braces attributeListP uniquenessExpr <- relExprP let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr @@ -127,7 +127,7 @@ keyP = do funcDepP :: Parser DatabaseContextExpr funcDepP = do reserved "funcdep" - keyName <- identifier + keyName <- identifierP source <- parens attributeListP reserved "->" dependents <- parens attributeListP @@ -141,7 +141,7 @@ funcDepP = do attributeAssignmentP :: Parser (AttributeName, AtomExpr) attributeAssignmentP = do - attrName <- identifier + attrName <- identifierP reservedOp ":=" atomExpr <- atomExprP pure (attrName, atomExpr) @@ -149,7 +149,7 @@ attributeAssignmentP = do addNotificationP :: Parser DatabaseContextExpr addNotificationP = do reserved "notify" - notName <- identifier + notName <- identifierP triggerExpr <- relExprP resultOldExpr <- relExprP AddNotification notName triggerExpr resultOldExpr <$> relExprP @@ -157,7 +157,7 @@ addNotificationP = do removeNotificationP :: Parser DatabaseContextExpr removeNotificationP = do reserved "unnotify" - RemoveNotification <$> identifier + RemoveNotification <$> identifierP -- | data Hair = Bald | Color Text addTypeConstructorP :: Parser DatabaseContextExpr diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs index 053d0992..16f3042e 100644 --- a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs @@ -15,7 +15,7 @@ addDatabaseContextFunctionExprP = dbioexprP "adddatabasecontextfunction" AddData createArbitraryRelationP :: Parser DatabaseContextIOExpr createArbitraryRelationP = do reserved "createarbitraryrelation" - relVarName <- identifier + relVarName <- identifierP attrExprs <- makeAttributeExprsP :: Parser [AttributeExpr] min' <- fromInteger <$> integer _ <- symbol "-" diff --git a/src/bin/TutorialD/Interpreter/Import/BasicExamples.hs b/src/bin/TutorialD/Interpreter/Import/BasicExamples.hs index 7fd6340a..3ae83056 100644 --- a/src/bin/TutorialD/Interpreter/Import/BasicExamples.hs +++ b/src/bin/TutorialD/Interpreter/Import/BasicExamples.hs @@ -20,7 +20,7 @@ evalImportBasicExampleOperator ImportBasicDateExampleOperator = databaseContextA importBasicExampleOperatorP :: Parser ImportBasicExampleOperator importBasicExampleOperatorP = do reservedOp ":importexample" - example <- identifier + example <- identifierP if example == "cjdate" then pure ImportBasicDateExampleOperator else diff --git a/src/bin/TutorialD/Interpreter/Import/CSV.hs b/src/bin/TutorialD/Interpreter/Import/CSV.hs index d56a1250..d40dbf92 100644 --- a/src/bin/TutorialD/Interpreter/Import/CSV.hs +++ b/src/bin/TutorialD/Interpreter/Import/CSV.hs @@ -25,6 +25,6 @@ importCSVP = do reserved ":importcsv" path <- quotedString spaceConsumer - relVarName <- identifier + relVarName <- identifierP return $ RelVarDataImportOperator relVarName (T.unpack path) importCSVRelation diff --git a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs index c52c10de..ecf31116 100644 --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -73,7 +73,7 @@ quitP = do showConstraintsP :: Parser RODatabaseContextOperator showConstraintsP = do colonOp ":constraints" - ShowConstraints <$> option "" identifier + ShowConstraints <$> option "" identifierP plotRelExprP :: Parser RODatabaseContextOperator plotRelExprP = do @@ -227,7 +227,7 @@ attrOrdersExprP :: Parser [DF.AttributeOrderExpr] attrOrdersExprP = reserved "orderby" *> braces (sepBy attrOrderExprP comma) attrOrderExprP :: Parser DF.AttributeOrderExpr -attrOrderExprP = DF.AttributeOrderExpr <$> identifier <*> orderP +attrOrderExprP = DF.AttributeOrderExpr <$> identifierP <*> orderP orderP :: Parser DF.Order orderP = try (reservedOp "ascending" >> pure DF.AscendingOrder) <|> try (reservedOp "descending" >> pure DF.DescendingOrder) <|> pure DF.AscendingOrder diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs index ba86b93b..d08c2d56 100644 --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -209,12 +209,12 @@ atomExprP = consumeAtomExprP True consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a) consumeAtomExprP consume = - try aggregateFunctionAtomExprP <|> try functionAtomExprP <|> ifThenAtomExprP <|> boolAtomExprP <|> -- we do this before the constructed atom parser to consume True and False try (parens (constructedAtomExprP True)) <|> constructedAtomExprP consume <|> + try subrelationAttributeExprP <|> relationalAtomExprP <|> attributeAtomExprP <|> try nakedAtomExprP @@ -261,17 +261,14 @@ subrelationAttributeNameP = do spaceConsumer pure (relAttr, subrelAttr) -aggregateFunctionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) -aggregateFunctionAtomExprP = do - fname <- functionNameP - parens $ do - aggInfo <- subrelationAttributeNameP - args <- try (do - void comma - sepBy atomExprP comma) - <|> pure [] - AggregateFunctionAtomExpr fname aggInfo args <$> parseMarkerP - +subrelationAttributeExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) +subrelationAttributeExprP = do + void $ single '@' + relAttr <- uncapitalizedOrQuotedIdentifier + void $ single '.' + subrelAttr <- uncapitalizedOrQuotedIdentifier + spaceConsumer + pure (SubrelationAttributeAtomExpr relAttr subrelAttr) functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) functionAtomExprP = @@ -317,7 +314,7 @@ withMacroExprP = do createMacroP :: RelationalMarkerExpr a => Parser (WithNameExprBase a, RelationalExprBase a) createMacroP = do - name <- identifier <* spaceConsumer + name <- identifierP reservedOp "as" expr <- relExprP marker <- parseMarkerP diff --git a/src/bin/TutorialD/Interpreter/SchemaOperator.hs b/src/bin/TutorialD/Interpreter/SchemaOperator.hs index e3177955..e1f5befe 100644 --- a/src/bin/TutorialD/Interpreter/SchemaOperator.hs +++ b/src/bin/TutorialD/Interpreter/SchemaOperator.hs @@ -19,7 +19,7 @@ schemaOperatorP = (ModifySchemaExpr <$> schemaExprP) <|> setCurrentSchemaP :: Parser SchemaOperator setCurrentSchemaP = do reserved ":setschema" - SetCurrentSchema <$> identifier + SetCurrentSchema <$> identifierP schemaExprP :: Parser SchemaExpr schemaExprP = addSubschemaP <|> @@ -28,7 +28,7 @@ schemaExprP = addSubschemaP <|> addSubschemaP :: Parser SchemaExpr addSubschemaP = do reserved ":addschema" - AddSubschema <$> identifier <*> parens (sepBy schemaIsomorphP comma) + AddSubschema <$> identifierP <*> parens (sepBy schemaIsomorphP comma) schemaIsomorphP :: Parser SchemaIsomorph schemaIsomorphP = isoRestrictP <|> isoUnionP <|> isoRenameP <|> isoPassthrough diff --git a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs index bb4a6172..8cb4c6e6 100644 --- a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs @@ -20,7 +20,7 @@ newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelation transactionIdLookupP :: Parser TransactionIdLookup transactionIdLookupP = (TransactionIdLookup <$> uuidP) <|> - (TransactionIdHeadNameLookup <$> identifier <*> many transactionIdHeadBacktrackP) + (TransactionIdHeadNameLookup <$> identifierP <*> many transactionIdHeadBacktrackP) transactionIdHeadBacktrackP :: Parser TransactionIdHeadBacktrack transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <$> backtrackP)) <|> diff --git a/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs b/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs index dafa950c..9d735b0a 100644 --- a/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs @@ -17,12 +17,12 @@ convenienceTransactionGraphOpP = autoMergeToHeadP autoMergeToHeadP :: Parser ConvenienceTransactionGraphOperator autoMergeToHeadP = do reserved ":automergetohead" - AutoMergeToHead <$> mergeTransactionStrategyP <*> identifier + AutoMergeToHead <$> mergeTransactionStrategyP <*> identifierP jumpToHeadP :: Parser TransactionGraphOperator jumpToHeadP = do reservedOp ":jumphead" - JumpToHead <$> identifier + JumpToHead <$> identifierP jumpToTransactionP :: Parser TransactionGraphOperator jumpToTransactionP = do @@ -37,12 +37,12 @@ walkBackToTimeP = do branchTransactionP :: Parser TransactionGraphOperator branchTransactionP = do reservedOp ":branch" - Branch <$> identifier + Branch <$> identifierP deleteBranchP :: Parser TransactionGraphOperator deleteBranchP = do reserved ":deletebranch" - DeleteBranch <$> identifier + DeleteBranch <$> identifierP commitTransactionP :: Parser TransactionGraphOperator commitTransactionP = do @@ -63,15 +63,15 @@ mergeTransactionStrategyP :: Parser MergeStrategy mergeTransactionStrategyP = (reserved "union" $> UnionMergeStrategy) <|> (do reserved "selectedbranch" - SelectedBranchMergeStrategy <$> identifier) <|> + SelectedBranchMergeStrategy <$> identifierP) <|> (do reserved "unionpreferbranch" - UnionPreferMergeStrategy <$> identifier) + UnionPreferMergeStrategy <$> identifierP) mergeTransactionsP :: Parser TransactionGraphOperator mergeTransactionsP = do reservedOp ":mergetrans" - MergeTransactions <$> mergeTransactionStrategyP <*> identifier <*> identifier + MergeTransactions <$> mergeTransactionStrategyP <*> identifierP <*> identifierP validateMerkleHashesP :: Parser ROTransactionGraphOperator validateMerkleHashesP = reservedOp ":validatemerklehashes" $> ValidateMerkleHashes diff --git a/src/bin/TutorialD/Interpreter/Types.hs b/src/bin/TutorialD/Interpreter/Types.hs index fcb6acdd..edd8bd0b 100644 --- a/src/bin/TutorialD/Interpreter/Types.hs +++ b/src/bin/TutorialD/Interpreter/Types.hs @@ -13,11 +13,11 @@ instance RelationalMarkerExpr () where parseMarkerP = pure () typeConstructorNameP :: Parser TypeConstructorName -typeConstructorNameP = capitalizedIdentifier +typeConstructorNameP = capitalizedIdentifier <* spaceConsumer dataConstructorNameP :: Parser DataConstructorName dataConstructorNameP = try $ do - ident <- capitalizedIdentifier + ident <- capitalizedIdentifier <* spaceConsumer when (ident `elem` ["True", "False"]) $ failure Nothing mempty --don't parse True or False as ConstructedAtoms (use NakedAtoms instead) pure ident @@ -63,10 +63,10 @@ attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a) attributeAndTypeNameP = AttributeAndTypeNameExpr <$> attributeNameP <*> typeConstructorP <*> parseMarkerP typeIdentifierP :: Parser TypeConstructorName -typeIdentifierP = capitalizedIdentifier +typeIdentifierP = capitalizedIdentifier <* spaceConsumer typeVariableIdentifierP :: Parser TypeVarName -typeVariableIdentifierP = uncapitalizedIdentifier +typeVariableIdentifierP = uncapitalizedIdentifier <* spaceConsumer -- *Either Int Text*, *Int* typeConstructorP :: Parser TypeConstructor diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs index 202ea844..839a54d5 100644 --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -40,14 +40,14 @@ instance Pretty Atom where pretty (UUIDAtom u) = pretty u pretty (RelationAtom x) = pretty x pretty (RelationalExprAtom re) = pretty re + pretty (SubrelationFoldAtom _rel _subAttr) = "SubrelationFoldAtom" -- this is only used as an argument to aggregate functions, so users should never be able to construct it directly pretty (ConstructedAtom n _ as) = pretty n <+> prettyList as instance Pretty AtomExpr where - pretty (AttributeAtomExpr attrName) = prettyAttributeName ("@" <> attrName) + pretty (AttributeAtomExpr attrName) = "@" <> prettyAttributeName attrName + pretty (SubrelationAttributeAtomExpr relAttr subAttr) = "@" <> prettyAttributeName relAttr <> "." <> prettyAttributeName subAttr pretty (NakedAtomExpr atom) = pretty atom pretty (FunctionAtomExpr atomFuncName' atomExprs _) = pretty atomFuncName' <> prettyAtomExprsAsArguments atomExprs - pretty (AggregateFunctionAtomExpr atomFuncName' aggInfo atomExprs _) = - pretty atomFuncName' <> error "unimplemented" pretty (RelationAtomExpr relExpr) = pretty relExpr pretty (IfThenAtomExpr ifE thenE elseE) = "if" <+> pretty ifE <+> "then" <+> pretty thenE <+> "else" <+> pretty elseE pretty (ConstructedAtomExpr dName [] _) = pretty dName @@ -156,6 +156,7 @@ instance Pretty AtomType where pretty BoolAtomType = "Bool" pretty UUIDAtomType = "UUID" pretty (RelationAtomType attrs) = "relation " <+> prettyBracesList (A.toList attrs) + pretty (SubrelationFoldAtomType typ) = "SubRelationFoldAtomType" <+> pretty typ pretty (ConstructedAtomType tcName tvMap) = pretty tcName <+> hsep (map pretty (M.toList tvMap)) --order matters pretty RelationalExprAtomType = "RelationalExpr" pretty (TypeVariableType x) = pretty x diff --git a/src/lib/ProjectM36/AggregateFunctions.hs b/src/lib/ProjectM36/AggregateFunctions.hs deleted file mode 100644 index b4208714..00000000 --- a/src/lib/ProjectM36/AggregateFunctions.hs +++ /dev/null @@ -1,26 +0,0 @@ -module ProjectM36.AggregateFunctions where -import ProjectM36.Base -import ProjectM36.Error -import ProjectM36.Relation -import ProjectM36.AtomFunctionError -import qualified Data.HashSet as HS - -functionForName :: FunctionName -> AggregateFunctions -> Either RelationalError AggregateFunction -functionForName fname aggFuncs = - if HS.null foundFunc then - Left $ NoSuchFunctionError fname - else - Right $ head $ HS.toList foundFunc - where - foundFunc = HS.filter (\f -> aggFuncName f == fname) aggFuncs - -evalAggregateFunction :: AggregateFunctionBodyType -> AttributeName -> Atom -> [Atom] -> Relation -> Either AtomFunctionError Atom -evalAggregateFunction foldFunc attrInTuple startVal foldFuncArgs rel = - relFold tupFolder (Right startVal) rel - where - tupFolder :: RelationTuple -> Either AtomFunctionError Atom -> Either AtomFunctionError Atom - tupFolder tup (Right acc) = - case foldFunc tup attrInTuple acc foldFuncArgs of - Left err -> Left err - Right acc' -> Right acc' - tupFolder _tup e@Left{} = e diff --git a/src/lib/ProjectM36/AggregateFunctions/Basic.hs b/src/lib/ProjectM36/AggregateFunctions/Basic.hs deleted file mode 100644 index a52420ad..00000000 --- a/src/lib/ProjectM36/AggregateFunctions/Basic.hs +++ /dev/null @@ -1,31 +0,0 @@ -module ProjectM36.AggregateFunctions.Basic where -import ProjectM36.Base -import ProjectM36.Tuple -import ProjectM36.AtomFunctionError -import qualified Data.HashSet as HS - --- count, sum, max, min -basicAggregateFunctions :: AggregateFunctions -basicAggregateFunctions = HS.fromList - [ -{- AggregateFunction { aggFuncName = "count", - aggFuncFoldFunc = (\_ _ rel -> - case cardinality rel of - Finite i -> pure (IntegerAtom (fromIntegral i)) - Countable -> Left InvalidIntBoundError), - aggFuncAccumType = IntegerAtomType - },-} - AggregateFunction { aggFuncName = "sum", - aggFuncFoldFunc = sumFold, - aggFuncFoldType = [IntegerAtomType], - aggFuncAccumType = IntegerAtomType - } - ] - -sumFold :: AggregateFunctionBodyType -sumFold tup attrName (IntegerAtom acc) [] = - case atomForAttributeName attrName tup of - Right (IntegerAtom i) -> pure (IntegerAtom (acc + i)) - Right _ -> Left AtomFunctionTypeMismatchError - Left _ -> Left (AtomFunctionAttributeNameNotFoundError attrName) -sumFold _ _ _ _ = Left AtomFunctionTypeMismatchError diff --git a/src/lib/ProjectM36/AtomFunction.hs b/src/lib/ProjectM36/AtomFunction.hs index a18ee043..72166a15 100644 --- a/src/lib/ProjectM36/AtomFunction.hs +++ b/src/lib/ProjectM36/AtomFunction.hs @@ -13,7 +13,9 @@ import qualified Data.Text as T foldAtomFuncType :: AtomType -> AtomType -> [AtomType] --the underscore in the attribute name means that any attributes are acceptable -foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType] +foldAtomFuncType foldType returnType = + [SubrelationFoldAtomType foldType, + returnType] atomFunctionForName :: FunctionName -> AtomFunctions -> Either RelationalError AtomFunction atomFunctionForName funcName' funcSet = if HS.null foundFunc then diff --git a/src/lib/ProjectM36/AtomFunctions/Primitive.hs b/src/lib/ProjectM36/AtomFunctions/Primitive.hs index 8a020e16..bc68b2b3 100644 --- a/src/lib/ProjectM36/AtomFunctions/Primitive.hs +++ b/src/lib/ProjectM36/AtomFunctions/Primitive.hs @@ -4,8 +4,8 @@ import ProjectM36.Relation (relFold, oneTuple) import ProjectM36.Tuple import ProjectM36.AtomFunctionError import ProjectM36.AtomFunction +import ProjectM36.AtomType import qualified Data.HashSet as HS -import qualified Data.Vector as V import Control.Monad import qualified Data.UUID as U import qualified Data.Text as T @@ -33,25 +33,26 @@ primitiveAtomFunctions = HS.fromList [ x:_ -> pure x _ -> Left AtomFunctionTypeMismatchError )}, - Function { funcName = "sum_agg", + Function { funcName = "sum", funcType = foldAtomFuncType IntegerAtomType IntegerAtomType, - funcBody = body $ relationAtomFunc relationSum + funcBody = body $ relationFoldFunc relationSum }, Function { funcName = "count", - funcType = foldAtomFuncType (TypeVariableType "a") IntegerAtomType, + funcType = [anyRelationAtomType, + IntegerAtomType], funcBody = body $ relationAtomFunc relationCount }, Function { funcName = "max", funcType = foldAtomFuncType IntegerAtomType IntegerAtomType, - funcBody = body $ relationAtomFunc relationMax + funcBody = body $ relationFoldFunc relationMax }, Function { funcName = "min", funcType = foldAtomFuncType IntegerAtomType IntegerAtomType, - funcBody = body $ relationAtomFunc relationMin + funcBody = body $ relationFoldFunc relationMin }, Function { funcName = "mean", funcType = foldAtomFuncType IntegerAtomType IntegerAtomType, - funcBody = body $ relationAtomFunc relationMean + funcBody = body $ relationFoldFunc relationMean }, Function { funcName = "eq", funcType = [TypeVariableType "a", TypeVariableType "a", BoolAtomType], @@ -128,8 +129,10 @@ primitiveAtomFunctions = HS.fromList [ ] <> scientificAtomFunctions where body = FunctionBuiltInBody - relationAtomFunc f [RelationAtom x] = f x + relationAtomFunc f [RelationAtom rel] = f rel relationAtomFunc _ _ = Left AtomFunctionTypeMismatchError + relationFoldFunc f [SubrelationFoldAtom rel subAttr] = f rel subAttr + relationFoldFunc _ _ = Left AtomFunctionTypeMismatchError integerAtomFuncLessThan :: Bool -> [Atom] -> Either AtomFunctionError Atom integerAtomFuncLessThan equality (IntegerAtom i1:IntegerAtom i2:_) = pure (BoolAtom (i1 `op` i2)) @@ -142,35 +145,48 @@ boolAtomNot (BoolAtom b) = pure (BoolAtom (not b)) boolAtomNot _ = error "boolAtomNot called on non-Bool atom" --used by sum atom function -relationSum :: Relation -> Either AtomFunctionError Atom -relationSum relIn = pure (IntegerAtom (relFold (\tupIn acc -> acc + newVal tupIn) 0 relIn)) +relationSum :: Relation -> AttributeName -> Either AtomFunctionError Atom +relationSum relIn subAttr = pure (IntegerAtom (relFold (\tupIn acc -> acc + newVal tupIn) 0 relIn)) where --extract Integer from Atom - newVal tupIn = castInteger (tupleAtoms tupIn V.! 0) + newVal tupIn = + case atomForAttributeName subAttr tupIn of + Left err -> error (show err) + Right atom -> castInteger atom relationCount :: Relation -> Either AtomFunctionError Atom relationCount relIn = pure (IntegerAtom (relFold (\_ acc -> acc + 1) (0::Integer) relIn)) -relationMax :: Relation -> Either AtomFunctionError Atom -relationMax relIn = case oneTuple relIn of +relationMax :: Relation -> AttributeName -> Either AtomFunctionError Atom +relationMax relIn subAttr = case oneTuple relIn of Nothing -> Left AtomFunctionEmptyRelationError Just oneTup -> pure (IntegerAtom (relFold (\tupIn acc -> max acc (newVal tupIn)) (newVal oneTup) relIn)) where - newVal tupIn = castInteger (tupleAtoms tupIn V.! 0) + newVal tupIn = + case atomForAttributeName subAttr tupIn of + Left err -> error (show err) + Right atom -> castInteger atom -relationMin :: Relation -> Either AtomFunctionError Atom -relationMin relIn = case oneTuple relIn of +relationMin :: Relation -> AttributeName -> Either AtomFunctionError Atom +relationMin relIn subAttr = case oneTuple relIn of Nothing -> Left AtomFunctionEmptyRelationError Just oneTup -> pure (IntegerAtom (relFold (\tupIn acc -> min acc (newVal tupIn)) (newVal oneTup) relIn)) where - newVal tupIn = castInteger (tupleAtoms tupIn V.! 0) + newVal tupIn = + case atomForAttributeName subAttr tupIn of + Left err -> error (show err) + Right atom -> castInteger atom -relationMean :: Relation -> Either AtomFunctionError Atom -relationMean relIn = case oneTuple relIn of + +relationMean :: Relation -> AttributeName -> Either AtomFunctionError Atom +relationMean relIn subAttr = case oneTuple relIn of Nothing -> Left AtomFunctionEmptyRelationError Just _oneTup -> do let (sum'', count') = relFold (\tupIn (sum', count) -> (sum' + newVal tupIn, count + 1)) (0, 0) relIn - newVal tupIn = castInteger (tupleAtoms tupIn V.! 0) + newVal tupIn = + case atomForAttributeName subAttr tupIn of + Left err -> error (show err) + Right atom -> castInteger atom pure (IntegerAtom (sum'' `div` count')) @@ -180,7 +196,7 @@ castInt _ = error "attempted to cast non-IntAtom to Int" castInteger :: Atom -> Integer castInteger (IntegerAtom i) = i -castInteger _ = error "attempted to cast non-IntegerAtom to Int" +castInteger _ = error "attempted to cast non-IntegerAtom to Integer" scientificAtomFunctions :: AtomFunctions diff --git a/src/lib/ProjectM36/AtomType.hs b/src/lib/ProjectM36/AtomType.hs index ef8f67d5..91eec9db 100644 --- a/src/lib/ProjectM36/AtomType.hs +++ b/src/lib/ProjectM36/AtomType.hs @@ -358,6 +358,9 @@ atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do else atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip (attributesVec attrs1) (attributesVec attrs2)) return x +atomTypeVerify (SubrelationFoldAtomType typ1) (SubrelationFoldAtomType typ2) = do + resTyp <- atomTypeVerify typ1 typ2 + pure (SubrelationFoldAtomType resTyp) atomTypeVerify x y = if x == y then Right x else @@ -457,4 +460,5 @@ isResolvedAttributes attrs = all isResolvedAttribute (V.toList (attributesVec at isResolvedAttribute :: Attribute -> Bool isResolvedAttribute = isResolvedType . A.atomType ---given two AtomTypes x,y +anyRelationAtomType :: AtomType +anyRelationAtomType = RelationAtomType (A.attributesFromList [Attribute "_" (TypeVariableType "a")]) diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs index 9e1cf372..994e1204 100644 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -360,7 +360,6 @@ data DatabaseContext = DatabaseContext { relationVariables :: RelationVariables, atomFunctions :: AtomFunctions, dbcFunctions :: DatabaseContextFunctions, - aggregateFunctions :: AggregateFunctions, notifications :: Notifications, typeConstructorMapping :: TypeConstructorMapping, registeredQueries :: RegisteredQueries @@ -512,10 +511,10 @@ type AggAtomFuncExprInfo = (AttributeName, AttributeName) -- (relvar attribute n -- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple. data AtomExprBase a = AttributeAtomExpr AttributeName | + SubrelationAttributeAtomExpr AttributeName AttributeName | NakedAtomExpr !Atom | FunctionAtomExpr !FunctionName [AtomExprBase a] a | -- as a simple, first aggregation case, we can only apply an aggregation to a RelationAtom while "selecting" one attribute - AggregateFunctionAtomExpr !FunctionName AggAtomFuncExprInfo [AtomExprBase a] a | RelationAtomExpr (RelationalExprBase a) | IfThenAtomExpr (AtomExprBase a) (AtomExprBase a) (AtomExprBase a) | -- if, then, else ConstructedAtomExpr DataConstructorName [AtomExprBase a] a @@ -648,30 +647,6 @@ type AtomFunctionBody = FunctionBody AtomFunctionBodyType type DatabaseContextFunction = Function DatabaseContextFunctionBodyType type DatabaseContextFunctionBody = FunctionBody DatabaseContextFunctionBodyType -type AggregateFunctions = HS.HashSet AggregateFunction -type AggregateFunctionBodyType = - RelationTuple -> -- ^ tuple inside the relation-valued attribute - AttributeName -> -- ^ the attribute of the RVA- in the future, this could be other projections on the tuple or perhaps a scalar expression - Atom -> -- ^ fold accumulator - [Atom] -> -- ^ other, static arguments - Either AtomFunctionError Atom - --- functions to be run on sub-relations- they can be built up from AtomFunctions -data AggregateFunction = - AggregateFunction { - aggFuncName :: FunctionName, - aggFuncFoldFunc :: AggregateFunctionBodyType, - aggFuncFoldType :: [AtomType], - aggFuncAccumType :: AtomType - } - deriving (Generic, NFData) - -instance Hashable AggregateFunction where - hashWithSalt salt func = salt `hashWithSalt` aggFuncName func `hashWithSalt` aggFuncAccumType func - -instance Eq AggregateFunction where - a == b = aggFuncName a == aggFuncName b - attrTypeVars :: Attribute -> S.Set TypeVarName attrTypeVars (Attribute _ aType) = case aType of IntAtomType -> S.empty diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index d846e3c7..6996dbca 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -4,7 +4,6 @@ import ProjectM36.AtomFunctionError import qualified Data.Map as M import qualified Data.HashSet as HS import ProjectM36.DataTypes.Primitive -import qualified Data.Vector as V import ProjectM36.AtomFunction import ProjectM36.Tuple import ProjectM36.Relation @@ -264,7 +263,7 @@ sqlSum :: [Atom] -> Either AtomFunctionError Atom sqlSum = sqlIntegerAgg (+) sqlIntegerAgg :: (Integer -> Integer -> Integer) -> [Atom] -> Either AtomFunctionError Atom -sqlIntegerAgg op [RelationAtom relIn] = +sqlIntegerAgg op [SubrelationFoldAtom relIn subAttr] = case oneTuple relIn of Nothing -> pure $ nullAtom IntegerAtomType Nothing -- SQL max/min of empty table is NULL Just oneTup -> @@ -273,7 +272,10 @@ sqlIntegerAgg op [RelationAtom relIn] = else pure $ relFold (\tupIn acc -> nullMax acc (newVal tupIn)) (newVal oneTup) relIn where - newVal tupIn = tupleAtoms tupIn V.! 0 + newVal tupIn = + case atomForAttributeName subAttr tupIn of + Left err -> error (show err) + Right atom -> atom nullMax acc nextVal = let mNextVal = sqlNullableIntegerToMaybe nextVal mOldVal = sqlNullableIntegerToMaybe acc diff --git a/src/lib/ProjectM36/DatabaseContext.hs b/src/lib/ProjectM36/DatabaseContext.hs index d64adfa9..6896f90d 100644 --- a/src/lib/ProjectM36/DatabaseContext.hs +++ b/src/lib/ProjectM36/DatabaseContext.hs @@ -8,7 +8,6 @@ import ProjectM36.DataTypes.Basic import ProjectM36.AtomFunctions.Basic import ProjectM36.Relation import ProjectM36.DatabaseContextFunction -import ProjectM36.AggregateFunctions.Basic empty :: DatabaseContext empty = DatabaseContext { inclusionDependencies = M.empty, @@ -16,7 +15,6 @@ empty = DatabaseContext { inclusionDependencies = M.empty, notifications = M.empty, atomFunctions = HS.empty, dbcFunctions = HS.empty, - aggregateFunctions = HS.empty, typeConstructorMapping = mempty, registeredQueries = mempty } @@ -40,7 +38,6 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty, ("false", ExistingRelation relationFalse)], atomFunctions = basicAtomFunctions, dbcFunctions = basicDatabaseContextFunctions, - aggregateFunctions = basicAggregateFunctions, notifications = M.empty, typeConstructorMapping = basicTypeConstructorMapping, registeredQueries = M.singleton "booleans" (Union (RelationVariable "true" ()) (RelationVariable "false" ())) diff --git a/src/lib/ProjectM36/HashSecurely.hs b/src/lib/ProjectM36/HashSecurely.hs index 9949e784..7b07fa14 100644 --- a/src/lib/ProjectM36/HashSecurely.hs +++ b/src/lib/ProjectM36/HashSecurely.hs @@ -50,6 +50,7 @@ instance HashBytes Atom where UUIDAtom u -> up ("UUIDAtom" <> BL.toStrict (UUID.toByteString u)) RelationAtom r -> hashBytesL ctx "RelationAtom" [SHash r] RelationalExprAtom e -> hashBytesL ctx "RelationalExprAtom" [SHash e] + SubrelationFoldAtom rel subAttr -> hashBytesL ctx "SubrelationFoldAtom" [SHash rel, SHash subAttr] ConstructedAtom d typ args -> hashBytesL ctx "ConstructedAtom" ([SHash d, SHash typ] <> map SHash args) where @@ -138,11 +139,10 @@ instance HashBytes a => HashBytes (AtomExprBase a) where hashBytes atomExpr ctx = case atomExpr of (AttributeAtomExpr a) -> hashBytesL ctx "AttributeAtomExpr" [SHash a] + (SubrelationAttributeAtomExpr relAttr subAttr) -> hashBytesL ctx "SubrelationAttributeAtomExpr" [SHash relAttr, SHash subAttr] (NakedAtomExpr a) -> hashBytesL ctx "NakedAtomExpr" [SHash a] (FunctionAtomExpr fname args marker) -> hashBytesL ctx "FunctionAtomExpr" $ [SHash fname, SHash marker] <> map SHash args - (AggregateFunctionAtomExpr fname aggInfo args marker) -> - hashBytesL ctx "AggregateFunctionAtomExpr" $ [SHash fname, SHash aggInfo, SHash marker] <> map SHash args (RelationAtomExpr r) -> hashBytesL ctx "RelationAtomExpr" [SHash r] (IfThenAtomExpr i t e) -> hashBytesL ctx "IfThenAtomExpr" [SHash i, SHash t, SHash e] (ConstructedAtomExpr dConsName args marker) -> @@ -167,6 +167,7 @@ instance HashBytes AtomType where RelationAtomType attrs -> hashBytesL ctx "RelationAtomType" (V.map SHash (attributesVec attrs)) ConstructedAtomType tConsName tvarMap -> hashBytesL ctx "ConstructedAtomType" (SHash tConsName : map SHash (M.toAscList tvarMap)) RelationalExprAtomType -> hashb "RelationalExprAtomType" + SubrelationFoldAtomType typ' -> hashBytesL ctx "SubrelationFoldAtomType" [SHash typ'] TypeVariableType tvn -> hashBytesL ctx "TypeVariableType" [SHash tvn] where hashb = SHA256.update ctx diff --git a/src/lib/ProjectM36/NormalizeExpr.hs b/src/lib/ProjectM36/NormalizeExpr.hs index a7090333..5868521c 100644 --- a/src/lib/ProjectM36/NormalizeExpr.hs +++ b/src/lib/ProjectM36/NormalizeExpr.hs @@ -112,11 +112,10 @@ processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = processAtomExpr :: AtomExpr -> ProcessExprM GraphRefAtomExpr processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam +processAtomExpr (SubrelationAttributeAtomExpr relAttr subAttr) = pure (SubrelationAttributeAtomExpr relAttr subAttr) processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom processAtomExpr (FunctionAtomExpr fName atomExprs ()) = FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> askMarker -processAtomExpr (AggregateFunctionAtomExpr fName aggInfo args ()) = - AggregateFunctionAtomExpr fName aggInfo <$> mapM processAtomExpr args <*> askMarker processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr processAtomExpr (IfThenAtomExpr ifE thenE elseE) = IfThenAtomExpr <$> processAtomExpr ifE <*> processAtomExpr thenE <*> processAtomExpr elseE diff --git a/src/lib/ProjectM36/ReferencedTransactionIds.hs b/src/lib/ProjectM36/ReferencedTransactionIds.hs index ebf5146f..6ef887fc 100644 --- a/src/lib/ProjectM36/ReferencedTransactionIds.hs +++ b/src/lib/ProjectM36/ReferencedTransactionIds.hs @@ -96,10 +96,9 @@ instance ReferencedTransactionIds a => ReferencedTransactionIds (AtomExprBase a) case expr of AttributeAtomExpr{} -> mempty NakedAtomExpr{} -> mempty + SubrelationAttributeAtomExpr{} -> mempty FunctionAtomExpr _ args marker -> S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args)) - AggregateFunctionAtomExpr _fname _aggInfo args marker -> - S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args)) RelationAtomExpr rExpr -> referencedTransactionIds rExpr ConstructedAtomExpr _ args marker -> diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index 65ebad3a..f270077c 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -18,7 +18,6 @@ import ProjectM36.DatabaseContextFunction import ProjectM36.Arbitrary import ProjectM36.GraphRefRelationalExpr import ProjectM36.Transaction -import ProjectM36.AggregateFunctions as Agg import qualified ProjectM36.Attribute as A import qualified Data.Map as M import qualified Data.HashSet as HS @@ -872,30 +871,6 @@ evalGraphRefAtomExpr tupIn (AttributeAtomExpr attrName) = evalGraphRefAtomExpr _ (NakedAtomExpr atom) = pure atom -- first argumentr is starting value, second argument is relationatom -evalGraphRefAtomExpr tupIn (AggregateFunctionAtomExpr funcName' (rvAttrName, aggAttributeName) arguments tid) = do - argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments - context <- gfDatabaseContextForMarker tid - let aggFuncs = aggregateFunctions context - --atomFuncs = atomFunctions context - traceShowM ("evalGraphRef agg"::String, rvAttrName, aggAttributeName) - aggFunc <- lift $ except (Agg.functionForName funcName' aggFuncs) - let zippedArgs = zip (safeInit (aggFuncFoldType aggFunc)) argTypes - safeInit [] = [] -- different behavior from normal init - safeInit xs = init xs - mapM_ (\(expType, actType) -> - lift $ except (atomTypeVerify expType actType)) zippedArgs - evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments - let startingVal = head evaldArgs - case atomForAttributeName rvAttrName tupIn of - Left err -> throwError err - Right (RelationAtom rel) -> do - traceShowM ("evalGraphRefAtomExpr"::String, aggAttributeName) - case evalAggregateFunction (aggFuncFoldFunc aggFunc) aggAttributeName startingVal [] rel of - Left err -> throwError (AtomFunctionUserError err) - Right v -> do - traceShowM ("evalGraphRefAtomExpr2"::String, v) - pure v - Right _ -> throwError (AttributeIsNotRelationValuedError rvAttrName) evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName' arguments tid) = do argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments context <- gfDatabaseContextForMarker tid @@ -924,6 +899,12 @@ evalGraphRefAtomExpr tupIn (RelationAtomExpr relExpr) = do let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn env relAtom <- lift $ except $ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr) pure (RelationAtom relAtom) +evalGraphRefAtomExpr tupIn (SubrelationAttributeAtomExpr relAttr subAttr) = do + atom <- evalGraphRefAtomExpr tupIn (AttributeAtomExpr relAttr) + case atom of + RelationAtom rel -> + pure (SubrelationFoldAtom rel subAttr) + _ -> throwError (AttributeIsNotRelationValuedError relAttr) evalGraphRefAtomExpr tupIn (IfThenAtomExpr ifExpr thenExpr elseExpr) = do conditional <- evalGraphRefAtomExpr tupIn ifExpr case conditional of @@ -938,7 +919,7 @@ evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do aType <- local mergeEnv (typeForGraphRefAtomExpr (tupleAttributes tupIn) cons) argAtoms <- local mergeEnv $ mapM (evalGraphRefAtomExpr tupIn) dConsArgs - pure (ConstructedAtom dConsName aType argAtoms) + pure (ConstructedAtom dConsName aType argAtoms) typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do @@ -952,17 +933,18 @@ typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do Right attr -> pure (A.atomType attr) Left _ -> case atomForAttributeName attrName envTup of Right atom -> pure (atomTypeForAtom atom) - Left _ -> --throwError (traceStack (show ("typeForGRAtomExpr", attrs, envTup)) err) + Left _ -> throwError err Left err -> throwError err - +typeForGraphRefAtomExpr attrs (SubrelationAttributeAtomExpr relAttr subAttr) = do + relType <- typeForGraphRefAtomExpr attrs (AttributeAtomExpr relAttr) + case relType of + RelationAtomType relAttrs -> + case A.atomTypeForAttributeName subAttr relAttrs of + Left err -> throwError err + Right attrType -> pure (SubrelationFoldAtomType attrType) + _ -> throwError (AttributeIsNotRelationValuedError relAttr) typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom) -typeForGraphRefAtomExpr attrs (AggregateFunctionAtomExpr funcName' aggInfo atomArgs transId) = do - context <- gfDatabaseContextForMarker transId - let aggFuncs = aggregateFunctions context - aggFunc <- lift $ except (Agg.functionForName funcName' aggFuncs) - let funcRetType = last (aggFuncFoldType aggFunc) - pure funcRetType typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName' atomArgs transId) = do funcs <- atomFunctions <$> gfDatabaseContextForMarker transId case atomFunctionForName funcName' funcs of @@ -976,7 +958,9 @@ typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName' atomArgs transId) = do argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs mapM_ (\(fArg,arg,argCount) -> do let handler :: RelationalError -> GraphRefRelationalExprM AtomType - handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType) + handler (AtomTypeMismatchError expSubType actSubType) = do + traceShowM ("typeForGraphRefAtomExpr"::String, expSubType, actSubType) + throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType) handler err = throwError err lift (except $ atomTypeVerify fArg arg) `catchError` handler ) (zip3 funcArgTypes argTypes [1..]) @@ -1024,8 +1008,11 @@ verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType = lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom) -verifyGraphRefAtomExprTypes relIn (AggregateFunctionAtomExpr funcName' aggInfo argExprs tid) expectedType = do - pure expectedType +verifyGraphRefAtomExprTypes relIn (SubrelationAttributeAtomExpr relAttr subAttr) expectedType = do + let mergedAttrsEnv = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn) + (Relation relAttrs _) <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr (RelationValuedAttribute relAttr)) + subAttrType <- lift $ except $ A.atomTypeForAttributeName subAttr relAttrs + lift $ except $ atomTypeVerify expectedType (SubrelationFoldAtomType subAttrType) verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName' funcArgExprs tid) expectedType = do context <- gfDatabaseContextForMarker tid let functions = atomFunctions context @@ -1033,7 +1020,9 @@ verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName' funcArgExprs tid) let expectedArgTypes = funcType func funcArgVerifier (atomExpr, expectedType2, argCount) = do let handler :: RelationalError -> GraphRefRelationalExprM AtomType - handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType) + handler (AtomTypeMismatchError expSubType actSubType) = do + traceShowM ("verifyGraphRefAtomExprTypes"::String, expSubType, actSubType) + throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType) handler err = throwError err verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..] @@ -1498,9 +1487,8 @@ instance ResolveGraphRefTransactionMarker GraphRefWithNameExpr where instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where resolve orig@AttributeAtomExpr{} = pure orig + resolve orig@SubrelationAttributeAtomExpr{} = pure orig resolve orig@NakedAtomExpr{} = pure orig - resolve (AggregateFunctionAtomExpr nam aggInfo args marker) = - AggregateFunctionAtomExpr nam aggInfo <$> mapM resolve args <*> pure marker resolve (FunctionAtomExpr nam atomExprs marker) = FunctionAtomExpr nam <$> mapM resolve atomExprs <*> pure marker resolve (RelationAtomExpr expr) = RelationAtomExpr <$> resolve expr diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index 2195176e..c1aafafe 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -639,7 +639,7 @@ convertWhereClause :: TypeForRelExprF -> RestrictionExpr -> ConvertM Restriction convertWhereClause typeF (RestrictionExpr rexpr) = do let wrongType t = throwSQLE $ TypeMismatchError t BoolAtomType --must be boolean expression coalesceBoolF expr = func "sql_coalesce_bool" [expr] - sqlEq l = func "sql_equals" l + sqlEq = func "sql_equals" case rexpr of IntegerLiteral{} -> wrongType IntegerAtomType DoubleLiteral{} -> wrongType DoubleAtomType @@ -945,7 +945,7 @@ joinTableRef typeF rvA (_c,tref) = do lookupOperator :: Bool -> OperatorName -> ConvertM ([AtomExpr] -> AtomExpr) lookupOperator isPrefix op@(OperatorName nam) | isPrefix = do - let f n args = func n args + let f = func case nam of ["-"] -> pure $ f "sql_negate" _ -> throwSQLE $ NoSuchSQLOperatorError op @@ -963,7 +963,7 @@ lookupFunc qname = Just match -> pure match other -> throwSQLE $ NotSupportedError ("function name: " <> T.pack (show other)) where - f n args = func n args + f = func aggMapper (FuncName [nam], nam') = (nam, f nam') aggMapper (FuncName other,_) = error ("unexpected multi-component SQL aggregate function: " <> show other) sqlFuncs = [(">",f "sql_gt"), @@ -1085,9 +1085,8 @@ pushDownAttributeRename renameSet matchExpr targetExpr = case expr of x@AttributeAtomExpr{} -> x --potential rename x@NakedAtomExpr{} -> x + x@SubrelationAttributeAtomExpr{} -> x FunctionAtomExpr fname args () -> FunctionAtomExpr fname (pushAtom <$> args) () - AggregateFunctionAtomExpr fname aggInfo args () -> - AggregateFunctionAtomExpr fname aggInfo (pushAtom <$> args) () --potential rename in aggInfo RelationAtomExpr e -> RelationAtomExpr (push e) IfThenAtomExpr ifE thenE elseE -> IfThenAtomExpr (pushAtom ifE) (pushAtom thenE) (pushAtom elseE) ConstructedAtomExpr dConsName args () -> ConstructedAtomExpr dConsName (pushAtom <$> args) () @@ -1484,6 +1483,7 @@ processSQLAggregateFunctions expr = case expr of AttributeAtomExpr{} -> expr NakedAtomExpr{} -> expr + SubrelationAttributeAtomExpr{} -> expr FunctionAtomExpr fname [AttributeAtomExpr attrName] () | fname == "sql_count" && -- count(*) counts the number of rows attrName == "_sql_aggregate" -> expr @@ -1495,10 +1495,8 @@ processSQLAggregateFunctions expr = (func "sql_isnull" [AttributeAtomExpr attrName]))) (RelationValuedAttribute "_sql_aggregate"))] | fname `elem` map snd aggregateFunctionsMap -> func fname - [RelationAtomExpr (Project (AttributeNames (S.singleton attrName)) (RelationValuedAttribute "_sql_aggregate"))] + [SubrelationAttributeAtomExpr "_sql_aggregate" attrName] FunctionAtomExpr fname args () -> FunctionAtomExpr fname (map processSQLAggregateFunctions args) () - AggregateFunctionAtomExpr fname aggInfo args () -> - AggregateFunctionAtomExpr fname aggInfo (processSQLAggregateFunctions <$> args) () RelationAtomExpr{} -> expr --not supported in SQL IfThenAtomExpr ifE thenE elseE -> IfThenAtomExpr (processSQLAggregateFunctions ifE) (processSQLAggregateFunctions thenE) (processSQLAggregateFunctions elseE) ConstructedAtomExpr{} -> expr --not supported in SQL diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index b4ec9bf4..233ac8cf 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -437,10 +437,10 @@ findStaticRestrictionPredicates AtomExprPredicate{} = M.empty isStaticAtomExpr :: AtomExpr -> Bool isStaticAtomExpr NakedAtomExpr{} = True +isStaticAtomExpr SubrelationAttributeAtomExpr{} = False isStaticAtomExpr ConstructedAtomExpr{} = True isStaticAtomExpr AttributeAtomExpr{} = False isStaticAtomExpr FunctionAtomExpr{} = False -isStaticAtomExpr AggregateFunctionAtomExpr{} = False isStaticAtomExpr IfThenAtomExpr{} = False isStaticAtomExpr RelationAtomExpr{} = False diff --git a/src/lib/ProjectM36/TransGraphRelationalExpression.hs b/src/lib/ProjectM36/TransGraphRelationalExpression.hs index c7010d45..bc60a884 100644 --- a/src/lib/ProjectM36/TransGraphRelationalExpression.hs +++ b/src/lib/ProjectM36/TransGraphRelationalExpression.hs @@ -122,11 +122,10 @@ processTransGraphTupleExpr (TupleExpr attrMap) = do processTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr processTransGraphAtomExpr (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname +processTransGraphAtomExpr (SubrelationAttributeAtomExpr relAttr subAttr) = pure $ SubrelationAttributeAtomExpr relAttr subAttr processTransGraphAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom processTransGraphAtomExpr (FunctionAtomExpr funcName' args tLookup) = FunctionAtomExpr funcName' <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup -processTransGraphAtomExpr (AggregateFunctionAtomExpr funcName' aggInfo args tLookup) = - AggregateFunctionAtomExpr funcName' aggInfo <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup processTransGraphAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processTransGraphRelationalExpr expr processTransGraphAtomExpr (IfThenAtomExpr ifE thenE elseE) = diff --git a/src/lib/ProjectM36/Transaction/Persist.hs b/src/lib/ProjectM36/Transaction/Persist.hs index 4b9c1c6c..de784851 100644 --- a/src/lib/ProjectM36/Transaction/Persist.hs +++ b/src/lib/ProjectM36/Transaction/Persist.hs @@ -12,7 +12,6 @@ import ProjectM36.Error import ProjectM36.Transaction import ProjectM36.DatabaseContextFunction import ProjectM36.AtomFunction -import ProjectM36.AggregateFunctions.Basic import ProjectM36.Persist (DiskSync, renameSync, writeSerialiseSync) import ProjectM36.Function import qualified Data.Map as M @@ -92,15 +91,12 @@ readTransaction dbdir transId mScriptSession = do notifs <- readNotifications transDir dbcFuncs <- readFuncs transDir (dbcFuncsPath transDir) basicDatabaseContextFunctions mScriptSession atomFuncs <- readFuncs transDir (atomFuncsPath transDir) precompiledAtomFunctions mScriptSession --- aggFuncs <- readAggFuncs transDir - let aggFuncs = basicAggregateFunctions registeredQs <- readRegisteredQueries transDir let newContext = DatabaseContext { inclusionDependencies = incDeps, relationVariables = relvars, typeConstructorMapping = typeCons, notifications = notifs, atomFunctions = atomFuncs, - aggregateFunctions = aggFuncs, dbcFunctions = dbcFuncs, registeredQueries = registeredQs } newSchemas = Schemas newContext sschemas @@ -288,12 +284,6 @@ readRegisteredQueries transDir = do let regQsPath = registeredQueriesPath transDir readFileDeserialise regQsPath -{- -readAggFuncs :: FilePath -> IO AggregateFunctions -readAggFuncs transDir = do - let aggFuncsPath = aggregateFunctionsPath transDir - HS.fromList <$> readFileDeserialise aggFuncsPath --} writeRegisteredQueries :: DiskSync -> FilePath -> RegisteredQueries -> IO () writeRegisteredQueries sync transDir regQs = do let regQsPath = registeredQueriesPath transDir diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs index 9d3f9215..65eea868 100644 --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -509,7 +509,6 @@ createUnionMergeTransaction stamp' newId strategy (t1,t2) = do incDeps <- liftMergeE $ unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB) relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB) atomFuncs <- liftMergeE $ unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB) - aggFuncs <- liftMergeE $ unionMergeAggregateFunctions preference (aggregateFunctions contextA) (aggregateFunctions contextB) notifs <- liftMergeE $ unionMergeMaps preference (notifications contextA) (notifications contextB) types <- liftMergeE $ unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB) dbcFuncs <- liftMergeE $ unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB) @@ -519,7 +518,6 @@ createUnionMergeTransaction stamp' newId strategy (t1,t2) = do inclusionDependencies = incDeps, relationVariables = relVars, atomFunctions = atomFuncs, - aggregateFunctions = aggFuncs, dbcFunctions = dbcFuncs, notifications = notifs, typeConstructorMapping = types, diff --git a/src/lib/ProjectM36/TransactionGraph/Merge.hs b/src/lib/ProjectM36/TransactionGraph/Merge.hs index 9f4d043b..b15fc6c3 100644 --- a/src/lib/ProjectM36/TransactionGraph/Merge.hs +++ b/src/lib/ProjectM36/TransactionGraph/Merge.hs @@ -63,13 +63,6 @@ unionMergeAtomFunctions prefer funcsA funcsB = case prefer of PreferSecond -> pure $ HS.union funcsB funcsA PreferNeither -> pure $ HS.union funcsA funcsB -unionMergeAggregateFunctions :: MergePreference -> AggregateFunctions -> AggregateFunctions -> Either MergeError AggregateFunctions -unionMergeAggregateFunctions prefer funcsA funcsB = - case prefer of - PreferFirst -> pure $ HS.union funcsA funcsB - PreferSecond -> pure $ HS.union funcsB funcsA - PreferNeither -> pure $ HS.union funcsA funcsB - unionMergeTypeConstructorMapping :: MergePreference -> TypeConstructorMapping -> TypeConstructorMapping -> Either MergeError TypeConstructorMapping unionMergeTypeConstructorMapping prefer typesA typesB = do let allFuncNames = S.fromList $ map (\(tc,_) -> TCD.name tc) (typesA ++ typesB) diff --git a/src/lib/ProjectM36/Tuple.hs b/src/lib/ProjectM36/Tuple.hs index c7fb0627..5c1b2d33 100644 --- a/src/lib/ProjectM36/Tuple.hs +++ b/src/lib/ProjectM36/Tuple.hs @@ -61,7 +61,6 @@ vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNa unknownAttrNames = V.filter (`V.notElem` attributeNames attrs) attrNameVec mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (attributeNames attrs)) - relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation relationForAttributeName attrName tuple = do aType <- atomTypeForAttributeName attrName (tupleAttributes tuple) diff --git a/src/lib/ProjectM36/WithNameExpr.hs b/src/lib/ProjectM36/WithNameExpr.hs index 7f0cf0fb..6efeb559 100644 --- a/src/lib/ProjectM36/WithNameExpr.hs +++ b/src/lib/ProjectM36/WithNameExpr.hs @@ -84,11 +84,10 @@ substituteWithNameMacrosAtomExpr :: GraphRefWithNameAssocs -> GraphRefAtomExpr - substituteWithNameMacrosAtomExpr macros atomExpr = case atomExpr of e@AttributeAtomExpr{} -> e + e@SubrelationAttributeAtomExpr{} -> e e@NakedAtomExpr{} -> e FunctionAtomExpr fname atomExprs tid -> FunctionAtomExpr fname (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid - AggregateFunctionAtomExpr fname aggInfo atomExprs tid -> - AggregateFunctionAtomExpr fname aggInfo (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid RelationAtomExpr reExpr -> RelationAtomExpr (substituteWithNameMacros macros reExpr) IfThenAtomExpr ifE thenE elseE -> diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index ad9c4fa6..b2fab605 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -24,6 +24,7 @@ import Test.HUnit import Text.Megaparsec import qualified Data.Text as T import qualified Data.Map as M +import TutorialD.Printer main :: IO () main = do @@ -59,7 +60,7 @@ testSelect = TestCase $ do (tgraph,transId) <- freshTransactionGraph sqlDBContext (sess, conn) <- dateExamplesConnection emptyNotificationCallback - let readTests = [ + let readTests = [{- -- simple relvar ("SELECT * FROM s", "(s)", "(s)"), -- simple projection @@ -163,24 +164,24 @@ testSelect = TestCase $ do ("SELECT abs(-4)", "((relation{}{tuple{}}:{attr_1:=sql_abs(sql_negate(4))}){attr_1})", "(relation{tuple{attr_1 SQLJust 4}})" - ), + ),-} -- where not exists -- group by with max aggregate ("SELECT city,max(status) FROM s GROUP BY city", - "((s group ({all but city} as `_sql_aggregate`) : {attr_2:=sql_max(@`_sql_aggregate`{status})}){city,attr_2})", + "((s group ({all but city} as `_sql_aggregate`) : {attr_2:=sql_max(@`_sql_aggregate`.status)}){city,attr_2})", "(relation{city Text, attr_2 SQLNullable Integer}{tuple{city \"London\", attr_2 SQLJust 20}, tuple{city \"Paris\", attr_2 SQLJust 30}, tuple{city \"Athens\", attr_2 SQLJust 30}})" - ), + ){-, -- group by with aggregate max column alias ("SELECT city,max(status) as status FROM s GROUP BY city", - "((s group ({all but city} as `_sql_aggregate`) : {status:=sql_max(@`_sql_aggregate`{status})}){city,status})", + "((s group ({all but city} as `_sql_aggregate`) : {status:=sql_max(@`_sql_aggregate`.status)}){city,status})", "(relation{city Text, status SQLNullable Integer}{tuple{city \"London\", status SQLJust 20}, tuple{city \"Paris\", status SQLJust 30}, tuple{city \"Athens\", status SQLJust 30}})"), -- aggregate max without grouping ("SELECT max(status) as status FROM s", - "(((s group ({all but } as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } )}){ status })", + "(((s group ({all but } as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`.status)}){ status })", "(relation{status SQLNullable Integer}{tuple{status SQLJust 30}})"), -- group by having max ("select city,max(status) as status from s group by city having max(status)=30", - "((((s group ({all but city} as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } ), `_sql_having`:=sql_coalesce_bool( sql_equals( sql_max( (@`_sql_aggregate`){ status } ), 30 ) )}){ city, status }) where `_sql_having`=True)", + "((((s group ({all but city} as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`.status), `_sql_having`:=sql_coalesce_bool( sql_equals( sql_max( (@`_sql_aggregate`.status), 30 ) )}){ city, status }) where `_sql_having`=True)", "(relation{city Text,status SQLNullable Integer}{tuple{city \"Athens\",status SQLJust 30},tuple{city \"Paris\",status SQLJust 30}})"), -- count(*) aggregate ("select count(*) as c from s", @@ -282,7 +283,7 @@ testSelect = TestCase $ do "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})"), ("SELECT NULL OR TRUE", "((relation{}{tuple{}}:{attr_1:=sql_or(SQLNullOfUnknownType,True)}){attr_1})", - "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust True}})") + "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust True}})")-} ] gfEnv = GraphRefRelationalExprEnv { gre_context = Just sqlDBContext, @@ -315,7 +316,7 @@ testSelect = TestCase $ do --print ("selectAsRelExpr"::String, queryAsRelExpr) --print ("expected: "::String, pretty tutdAsDFExpr) - --print ("actual : "::String, pretty queryAsDFExpr) + print ("actual : "::String, renderPretty queryAsDFExpr) assertEqual (T.unpack sql) tutdAsDFExpr queryAsDFExpr --check that the expression can actually be executed eEvald <- executeDataFrameExpr sess conn tutdAsDFExpr diff --git a/test/TutorialD/InterpreterTest.hs b/test/TutorialD/InterpreterTest.hs index 48d594d6..da50c1b9 100644 --- a/test/TutorialD/InterpreterTest.hs +++ b/test/TutorialD/InterpreterTest.hs @@ -95,7 +95,8 @@ main = do testShowDDL, testRegisteredQueries, testCrossJoin, - testIfThenExpr + testIfThenExpr, + testSubrelationAttributeAtomExpr ] simpleRelTests :: Test @@ -184,14 +185,14 @@ dateExampleRelTests = TestCase $ do --relatom function tests ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntegerAtom 1)])), ("x:=(sp group ({s#} as y)) ungroup y", Right supplierProductsRel), - ("x:=((sp{s#,qty}) group ({qty} as x):{z:=max(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])), - ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])), - ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])), + ("x:=((sp{s#,qty}) group ({qty} as x):{z:=max(@x.qty)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])), + ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x.qty)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])), + ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x.qty)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])), --boolean function restriction ("x:=s where lt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]), ("x:=s where gt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]), - ("x:=s where sum(@status)", Left $ AtomFunctionTypeError "sum" 1 (RelationAtomType (attributesFromList [Attribute "_" IntegerAtomType])) IntegerAtomType), + ("x:=s where sum(@status)", Left $ AtomFunctionTypeError "sum" 1 (SubrelationFoldAtomType IntegerAtomType) IntegerAtomType), ("x:=s where not(gte(@status,20))", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]), --test "all but" attribute inversion syntax ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue), @@ -805,7 +806,7 @@ testDDLHash = TestCase $ do Right hash2 <- getDDLHash sessionId dbconn assertBool "add relvar" (hash1 /= hash2) -- the test should break if the hash is calculated differently - assertEqual "static hash check" "ds0uvEvV8CvivyYyxJ75S0CeAnNzKAAH5AdOv74+ydM=" (B64.encode (_unSecureHash hash1)) + assertEqual "static hash check" "3aNi/azK9QNSXQQQ0QOuGcqAPlRh0d7zX0bNwjowPDA=" (B64.encode (_unSecureHash hash1)) -- remove an rv executeTutorialD sessionId dbconn "undefine x" Right hash3 <- getDDLHash sessionId dbconn @@ -876,3 +877,12 @@ testIfThenExpr = TestCase $ do executeTutorialD session dbconn "x:=(s:{islondon:=if eq(@city,\"London\") then True else False}){city,islondon} = relation{tuple{city \"London\", islondon True},tuple{city \"Paris\",islondon False},tuple{city \"Athens\", islondon False}}" eEqRel <- executeRelationalExpr session dbconn (RelationVariable "x" ()) assertEqual "if-then" (Right relationTrue) eEqRel + +testSubrelationAttributeAtomExpr :: Test +testSubrelationAttributeAtomExpr = TestCase $ do + (session, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD session dbconn "x:=(s group ({all from s} as sub):{l:=sum(@sub.status)}){l}" + executeTutorialD session dbconn "y:=relation{tuple{l 110}}" + executeTutorialD session dbconn "z:= x = y" + res <- executeRelationalExpr session dbconn (RelationVariable "z" ()) + assertEqual "sum" (Right relationTrue) res From 6db710feb02a9b908a2abb4cc68a17bf22b75628 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 14 Jul 2024 11:12:12 -0400 Subject: [PATCH 144/170] update documentation for subrelation attribute aggregations remove debug.trace --- Changelog.markdown | 4 +++ docs/tutd_cheatsheet.markdown | 1 + docs/tutd_tutorial.markdown | 35 ++++++++++++++++++++-- project-m36.cabal | 2 +- src/lib/ProjectM36/RelationalExpression.hs | 4 --- 5 files changed, 38 insertions(+), 8 deletions(-) diff --git a/Changelog.markdown b/Changelog.markdown index 4e2dc79f..2c718839 100644 --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,7 @@ +# 2024-07-15 (v1.0.1) + +* add support for aggregate functions using sub-relation attributes + # 2024-06-06 (v1.0.0) * add support for relational expression evaluation against sub-relations diff --git a/docs/tutd_cheatsheet.markdown b/docs/tutd_cheatsheet.markdown index 016b3fa3..3083338d 100644 --- a/docs/tutd_cheatsheet.markdown +++ b/docs/tutd_cheatsheet.markdown @@ -22,6 +22,7 @@ Relational expressions query database state without being able to change it. |`:showexpr s where lt(@status, 30)`|Display the result of `s` where the `status` is less than 30.| |`:showexpr s relwhere (p{})`|Display the result of `s` if the `p` relation variable is non-empty.| |`:showexpr s group ({sname,status,s#} as subrel)`| Display the result of grouping the `sname`, `status`, and `s#` into a subrel for each tuple in the `s` relation where the `city` attribute (not mentioned) is the grouping criteria| +|`:showexpr s group ({all but city} as g):{city_total:=sum(@g.status)}|Display the result of grouping suppliers by city and the sum total status of each city.| |`:showexpr (s group ({sname,status,s#} as subrel)) ungroup subrel`| Display the result of unwrapping a subrelation to create one new tuple for each subrelation tuple in the result| |`:showexpr s minus s`|Display the result after removing all tuples that match the second argument. `x minus x` is equivalent to `x where false`| |`:showexpr relation{tuple{name "Mike",age 6},tuple{name "Sam",age 10}}`|Display an unnamed relation using manually constructed tuples| diff --git a/docs/tutd_tutorial.markdown b/docs/tutd_tutorial.markdown index ac685d31..2c0bf8be 100644 --- a/docs/tutd_tutorial.markdown +++ b/docs/tutd_tutorial.markdown @@ -658,12 +658,41 @@ TutorialD (master/main): :showexpr s group ({s#,sname,status} as subrel):{cityco In this query result, we can simultaneously answer how many suppliers are located in each city and which suppliers they are. The expression is constructed by first grouping to isolate the city, then extending the query to add a attribute containing the tuple count for each subrelation. +For aggregations that reference a specific attribute ("count" does rely on any attribute), use the subrelation attribute syntax `@subrel.subrelattr`: + +``` +TutorialD (master/main): :showexpr s group ({all but city} as g):{city_total:=sum(@g.status)} +┌──────────┬───────────────────┬──────────────────────────────────────────────────┐ +│city::Text│city_total::Integer│g::relation {s#::Text,sname::Text,status::Integer}│ +├──────────┼───────────────────┼──────────────────────────────────────────────────┤ +│"Paris" │40 │┌────────┬───────────┬───────────────┐ │ +│ │ ││s#::Text│sname::Text│status::Integer│ │ +│ │ │├────────┼───────────┼───────────────┤ │ +│ │ ││"S2" │"Jones" │10 │ │ +│ │ ││"S3" │"Blake" │30 │ │ +│ │ │└────────┴───────────┴───────────────┘ │ +│"London" │40 │┌────────┬───────────┬───────────────┐ │ +│ │ ││s#::Text│sname::Text│status::Integer│ │ +│ │ │├────────┼───────────┼───────────────┤ │ +│ │ ││"S4" │"Clark" │20 │ │ +│ │ ││"S1" │"Smith" │20 │ │ +│ │ │└────────┴───────────┴───────────────┘ │ +│"Athens" │30 │┌────────┬───────────┬───────────────┐ │ +│ │ ││s#::Text│sname::Text│status::Integer│ │ +│ │ │├────────┼───────────┼───────────────┤ │ +│ │ ││"S5" │"Adams" │30 │ │ +│ │ │└────────┴───────────┴───────────────┘ │ +└──────────┴───────────────────┴──────────────────────────────────────────────────┘ + +``` + |Function Name|Description| |-------------|-----------| |count(relation{any tuple types})|return the number of tuples in each relation value| -|sum(relation{int})|return the int sum of the relation's values| -|max(relation{int})|return the maximum int from all the relation's values| -|min(relation{int})|return the minimum int from all the relation's values| +|sum(subrelation attribute{Integer})|return the int sum from all the subrelation's values for the attribute| +|max(subrelation attribute{Integer})|return the maximum int from all the subrelation's values for the attribute| +|min(subrelation attribute{Integer})|return the minimum int from all the subrelation's values for the attribute| +|mean(subrelation attribute{Integer})|return the mean from all the subrelation's values for the attribute| #### Arbitrary Relation Variables diff --git a/project-m36.cabal b/project-m36.cabal index e3d5a2cf..11327c6e 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 1.0.0 +Version: 1.0.1 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index f270077c..bd6e2ff2 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -51,8 +51,6 @@ import Control.Exception import GHC.Paths #endif -import Debug.Trace - data DatabaseContextExprDetails = CountUpdatedTuples databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc @@ -959,7 +957,6 @@ typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName' atomArgs transId) = do mapM_ (\(fArg,arg,argCount) -> do let handler :: RelationalError -> GraphRefRelationalExprM AtomType handler (AtomTypeMismatchError expSubType actSubType) = do - traceShowM ("typeForGraphRefAtomExpr"::String, expSubType, actSubType) throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType) handler err = throwError err lift (except $ atomTypeVerify fArg arg) `catchError` handler @@ -1021,7 +1018,6 @@ verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName' funcArgExprs tid) funcArgVerifier (atomExpr, expectedType2, argCount) = do let handler :: RelationalError -> GraphRefRelationalExprM AtomType handler (AtomTypeMismatchError expSubType actSubType) = do - traceShowM ("verifyGraphRefAtomExprTypes"::String, expSubType, actSubType) throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType) handler err = throwError err verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler From 8572a983999d69c5cb3a6206f141043e519aa155 Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 19 Jul 2024 13:08:43 -0400 Subject: [PATCH 145/170] wip fix websocket json encodings expose createSessionAtHead to websocket API --- .../ProjectM36/Server/RemoteCallTypes/Json.hs | 8 ++ src/bin/ProjectM36/Server/WebSocket.hs | 80 ++++++++++++++----- .../Server/WebSocket/project-m36.js | 5 ++ 3 files changed, 74 insertions(+), 19 deletions(-) diff --git a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs index 697636ac..1363250e 100644 --- a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +++ b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs @@ -110,6 +110,11 @@ instance ToJSON Atom where "val" .= u ] toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] + toJSON atom@(SubrelationFoldAtom rel attrName) = object [ "type" .= atomTypeForAtom atom, + "val" .= + object [ "relation" .= rel, + "attributeName" .= attrName] + ] toJSON atom@(RelationalExprAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] toJSON (ConstructedAtom dConsName atomtype atomlist) = object [ @@ -148,6 +153,9 @@ instance FromJSON Atom where Just u -> pure $ UUIDAtom u Nothing -> fail "Invalid UUID String" RelationalExprAtomType -> RelationalExprAtom <$> o .: "val" + SubrelationFoldAtomType _ -> do + val <- o .: "val" + SubrelationFoldAtom <$> val .: "relation" <*> val .: "attributeName" instance ToJSON Notification instance FromJSON Notification diff --git a/src/bin/ProjectM36/Server/WebSocket.hs b/src/bin/ProjectM36/Server/WebSocket.hs index 1f6b264e..89164d5b 100644 --- a/src/bin/ProjectM36/Server/WebSocket.hs +++ b/src/bin/ProjectM36/Server/WebSocket.hs @@ -18,11 +18,12 @@ import TutorialD.Interpreter import ProjectM36.Interpreter (ConsoleResult(..), SafeEvaluationFlag(..)) import ProjectM36.Client import Control.Exception -import Data.Attoparsec.Text +import Data.Attoparsec.Text as Atto import Control.Applicative import Text.Megaparsec.Error import Data.Functor import Data.Either (fromRight) +import qualified Data.UUID as UUID #if MIN_VERSION_megaparsec(7,0,0) import Data.List.NonEmpty as NE @@ -44,20 +45,21 @@ websocketProxyServer port host pending = do Left _ -> pure ()) $ \case Left err -> sendError conn err Right dbconn -> do - eSessionId <- createSessionAtHead dbconn "master" - case eSessionId of - Left err -> sendError conn err - Right sessionId -> do - --phase 2- accept tutoriald commands - _ <- forever $ do - pInfo <- promptInfo sessionId dbconn - --figure out why sending three times during startup is necessary - sendPromptInfo pInfo conn - sendPromptInfo pInfo conn - msg <- WS.receiveData conn :: IO T.Text - case parseOnly parseExecuteMessage msg of + --phase 2- accept tutoriald commands + _ <- forever $ do + {-pInfo <- promptInfo sessionId dbconn + --figure out why sending three times during startup is necessary + sendPromptInfo pInfo conn + sendPromptInfo pInfo conn-} + msg <- WS.receiveData conn :: IO T.Text + case parseOnly parseIncomingRequest msg of Left _ -> unexpectedMsg - Right (presentation, tutdString) -> + Right (CreateSessionAtHeadRequest branchName) -> do + ret <- createSessionAtHead dbconn branchName + case ret of + Left err -> handleOpResult conn dbconn jsonOnlyPresentation (DisplayErrorResult ("createSessionAtHead error: " <> T.pack (show err))) + + Right (ExecuteTutorialDRequest sessionId presentation tutdString) -> case parseTutorialD tutdString of Left err -> handleOpResult conn dbconn presentation #if MIN_VERSION_megaparsec(7,0,0) @@ -77,7 +79,7 @@ websocketProxyServer port host pending = do sendPromptInfo pInfo' conn handleOpResult conn dbconn presentation result catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn presentation (DisplayErrorResult "Request Timed Out.")) - pure () + pure () notificationCallback :: WS.Connection -> NotificationCallback notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName, @@ -136,10 +138,22 @@ data Presentation = Presentation { textPresentation :: Bool, htmlPresentation :: Bool } +jsonOnlyPresentation :: Presentation +jsonOnlyPresentation = Presentation { jsonPresentation = True, + textPresentation = False, + htmlPresentation = False } + data PresentationFlag = JSONFlag | TextFlag | HTMLFlag -parseExecuteMessage :: Parser (Presentation, T.Text) -parseExecuteMessage = do +data IncomingRequest = ExecuteTutorialDRequest SessionId Presentation T.Text | + CreateSessionAtHeadRequest HeadName + +parseIncomingRequest :: Parser IncomingRequest +parseIncomingRequest = parseExecuteTutorialDMessage <|> + parseCreateSessionAtHead + +parseExecuteTutorialDMessage :: Parser IncomingRequest +parseExecuteTutorialDMessage = do _ <- string "executetutd/" flags <- sepBy ((string "json" $> JSONFlag) <|> (string "text" $> TextFlag) <|> @@ -149,5 +163,33 @@ parseExecuteMessage = do TextFlag -> acc {textPresentation = True} HTMLFlag -> acc {htmlPresentation = True}) (Presentation False False False) flags _ <- char ':' - tutd <- T.pack <$> manyTill anyChar endOfInput - pure (presentation, tutd) + sessionId <- sessionIdP + _ <- char ':' + tutd <- takeText + pure (ExecuteTutorialDRequest sessionId presentation tutd) + +parseCreateSessionAtHead :: Parser IncomingRequest +parseCreateSessionAtHead = do + _ <- string "createSessionAtHead:" + CreateSessionAtHeadRequest <$> takeText + +textToEOFP :: Parser T.Text +textToEOFP = T.pack <$> manyTill anyChar endOfInput + +sessionIdP :: Parser SessionId +sessionIdP = do + let hexDigitP = satisfy isHexDigit + nHexDigitsP n = T.pack <$> Atto.count n hexDigitP + isHexDigit c = (c >= '0' && c <= '9') || + (c >= 'a' && c <= 'f') || + (c >= 'A' && c <= 'F') + a <- nHexDigitsP 8 + _ <- char '-' + b <- nHexDigitsP 4 + _ <- char '-' + c <- nHexDigitsP 4 + _ <- char '-' + d <- nHexDigitsP 12 + case UUID.fromText (T.concat [a,b,c,d]) of + Nothing -> fail "invalid UUID" + Just uuid -> pure uuid diff --git a/src/bin/ProjectM36/Server/WebSocket/project-m36.js b/src/bin/ProjectM36/Server/WebSocket/project-m36.js index 2fd1d221..2caf7705 100644 --- a/src/bin/ProjectM36/Server/WebSocket/project-m36.js +++ b/src/bin/ProjectM36/Server/WebSocket/project-m36.js @@ -48,6 +48,11 @@ var ProjectM36Connection = function (protocol, host, port, path, dbname, openCal this.socket = socket; } +ProjectM36Connection.prototype.createSessionAtHead(branch) +{ + this.socket.send("createSessionAtHead:" + branch) +} + /** * The argument returned as part of the 'statusCallback'. Typically, only one of the three status types is populated. These status updates are groups together so that the callback can feed into a user interface update function. * @callback statusCallback From b2527705c970b78fee0091b88cbe1decf7feb267 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 20 Jul 2024 23:45:43 -0400 Subject: [PATCH 146/170] wip second attempt at moving to streamly 0.10.1 after streamly-bytestring was fixed to handle pinned arrays in 0.2.2 --- project-m36.cabal | 62 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 61 insertions(+), 1 deletion(-) diff --git a/project-m36.cabal b/project-m36.cabal index 11327c6e..b0fb94a0 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -36,7 +36,67 @@ Flag haskell-scripting Default: True Library - Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.5, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific + Build-Depends: + base>=4.16 && < 4.19, + ghc-paths, + mtl, + containers, + unordered-containers, + hashable, + haskeline, + directory, + MonadRandom, + random-shuffle, + uuid >= 1.3.12, + cassava >= 0.4.5.1 && < 0.6, + text, + bytestring, + deepseq, + deepseq-generics, + vector, + parallel, + monad-parallel, + exceptions, + transformers, + gnuplot, + filepath, + zlib, + directory, + temporary, + stm, + time, + old-locale, + rset, + attoparsec, + either, + base64-bytestring, + data-interval, + extended-reals, + aeson >= 1.1, + path-pieces, + conduit, + resourcet, + http-api-data, + semigroups, + QuickCheck, + quickcheck-instances, + list-t, + stm-containers >= 0.2.15, + foldl, + optparse-applicative, + Glob, + cryptohash-sha256, + text-manipulate >= 0.2.0.1 && < 0.4, + winery >= 1.4, + curryer-rpc>=0.3.6, + network, + async, + vector-instances, + recursion-schemes, + streamly == 0.10.1, + convertible, + fast-builder, + scientific if flag(haskell-scripting) Build-Depends: ghc >= 9.0 && < 9.5 CPP-Options: -DPM36_HASKELL_SCRIPTING From 0c8ad289b30be347e04b9f9f8ebc43ae6d468193 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 21 Jul 2024 02:41:39 -0400 Subject: [PATCH 147/170] fix docker build for streamly and curryer-rpc upgrades --- release.nix | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/release.nix b/release.nix index 2650dad2..86e10f4b 100644 --- a/release.nix +++ b/release.nix @@ -15,18 +15,18 @@ let overrides = self: super: { curryer-rpc = self.callHackageDirect { pkg = "curryer-rpc"; - ver = "0.3.5"; - sha256 = "sha256-7mEJOBKzA2rTnLxZme8E6zFv0VkiXBo5L/jUJSNPaNE="; } {}; + ver = "0.3.6"; + sha256 = "sha256-GgYxb3eBhANGMdN3FlMgD9vZUqoDsz89OFIBxwK4YtY="; } {}; streamly = self.callHackageDirect { pkg = "streamly"; - ver = "0.9.0"; - sha256 = "sha256-eOxVb8qQjZDo1+S7CStqYSExOg2QHWkMY+zlOYqwZak="; } {}; + ver = "0.10.1"; + sha256 = "sha256-9tWZ/8YteD9ljhEmj8oYKIAyFcbQflX0D20j/NTe3qM="; } {}; streamly-core = self.callHackageDirect { pkg = "streamly-core"; - ver = "0.1.0"; - sha256 = "sha256-hoSV6Q2+X5a7hFnJAArqNPjcMaCVyX9Vz4FcxeJ+jgI="; } {}; + ver = "0.2.2"; + sha256 = "sha256-Ggo5ius3dp/TJFfrZSk31A6gSZHA6kLMtxFKe9MIvqQ="; } {}; streamly-bytestring = self.callHackageDirect { pkg = "streamly-bytestring"; From d3405f08c87cb8471888383d08af4f0ea74a9ec7 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 21 Jul 2024 11:18:51 -0400 Subject: [PATCH 148/170] update nix streamly-bytesting --- release.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/release.nix b/release.nix index 86e10f4b..2acff7da 100644 --- a/release.nix +++ b/release.nix @@ -30,8 +30,8 @@ let streamly-bytestring = self.callHackageDirect { pkg = "streamly-bytestring"; - ver = "0.2.1"; - sha256 = "sha256-EcH6qq4nRjea3xQ66Zlqgjjg7lF/grkKJI0+tTO4B84="; } {}; + ver = "0.2.2"; + sha256 = "sha256-E/sMAvaJ5zGYwb5KAXa2KQo3FqyB+T2mRO6zOTCXpoY="; } {}; lockfree-queue = self.callHackageDirect { pkg = "lockfree-queue"; From d11d7bfae9f4285b33ed4a6f79884b766272b6a4 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 21 Jul 2024 11:19:10 -0400 Subject: [PATCH 149/170] update streamly and curryer-rpc for stack --- stack.ghc9.2.yaml | 8 ++++---- stack.ghc9.4.yaml | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/stack.ghc9.2.yaml b/stack.ghc9.2.yaml index 92b64d88..f40f7b57 100644 --- a/stack.ghc9.2.yaml +++ b/stack.ghc9.2.yaml @@ -3,10 +3,10 @@ packages: - "." extra-deps: - - streamly-0.9.0 - - streamly-core-0.1.0 - - streamly-bytestring-0.2.0 - - curryer-rpc-0.3.2 + - streamly-0.10.1 + - streamly-core-0.2.2 + - streamly-bytestring-0.2.2 + - curryer-rpc-0.3.6 - fast-builder-0.1.2.1 - rset-1.0.0 - winery-1.4 diff --git a/stack.ghc9.4.yaml b/stack.ghc9.4.yaml index 3655a136..673521a0 100644 --- a/stack.ghc9.4.yaml +++ b/stack.ghc9.4.yaml @@ -3,9 +3,9 @@ packages: - "." extra-deps: - - streamly-0.9.0 - - streamly-core-0.1.0 - - streamly-bytestring-0.2.0 + - streamly-0.10.1 + - streamly-core-0.2.2 + - streamly-bytestring-0.2.2 - curryer-rpc-0.3.2 - fast-builder-0.1.2.1 - rset-1.0.0 From 873ae8c500fc107d772ed790976f054337e1a07f Mon Sep 17 00:00:00 2001 From: AgentM Date: Mon, 22 Jul 2024 11:18:30 -0400 Subject: [PATCH 150/170] wip websocket server request-response overhaul --- src/bin/ProjectM36/Server/WebSocket.hs | 263 +++++++++++++++++++------ 1 file changed, 201 insertions(+), 62 deletions(-) diff --git a/src/bin/ProjectM36/Server/WebSocket.hs b/src/bin/ProjectM36/Server/WebSocket.hs index 89164d5b..8cb4ab25 100644 --- a/src/bin/ProjectM36/Server/WebSocket.hs +++ b/src/bin/ProjectM36/Server/WebSocket.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, CPP #-} +{-# LANGUAGE LambdaCase, CPP, GeneralizedNewtypeDeriving, DeriveAnyClass, DeriveGeneric, DerivingStrategies, ScopedTypeVariables #-} module ProjectM36.Server.WebSocket where -- while the tutd client performs TutorialD parsing on the client, the websocket server will pass tutd to be parsed and executed on the server- otherwise I have to pull in ghcjs as a dependency to allow client-side parsing- that's not appealing because then the frontend is not language-agnostic, but this could change in the future, perhaps by sending different messages over the websocket -- ideally, the wire protocol should not be exposed to a straight string-based API ala SQL, so we could make perhaps a javascript DSL which compiles to the necessary JSON- anaylyze tradeoffs @@ -14,16 +14,18 @@ import ProjectM36.DataFrame import ProjectM36.Relation.Show.Term import ProjectM36.Relation.Show.HTML import Data.Aeson +import ProjectM36.Base import TutorialD.Interpreter import ProjectM36.Interpreter (ConsoleResult(..), SafeEvaluationFlag(..)) import ProjectM36.Client import Control.Exception import Data.Attoparsec.Text as Atto -import Control.Applicative import Text.Megaparsec.Error import Data.Functor import Data.Either (fromRight) +import qualified Data.ByteString.Lazy as BS import qualified Data.UUID as UUID +import GHC.Generics #if MIN_VERSION_megaparsec(7,0,0) import Data.List.NonEmpty as NE @@ -34,16 +36,17 @@ websocketProxyServer port host pending = do conn <- WS.acceptRequest pending let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text) --phase 1- accept database name for connection - dbmsg <- WS.receiveData conn :: IO T.Text - let connectdbmsg = "connectdb:" - if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text) - else do - let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg + dbmsg <- WS.receiveData conn :: IO BS.ByteString + case eitherDecode dbmsg of + Left _ -> do + unexpectedMsg + WS.sendClose conn ("" :: T.Text) + Right (ConnectionSetupRequest dbname) -> do bracket (createConnection conn dbname port host) (\case Right dbconn -> close dbconn Left _ -> pure ()) $ \case - Left err -> sendError conn err + Left err -> sendResponse conn (TextErrorResponse (RequestId UUID.nil) (T.pack (show err))) Right dbconn -> do --phase 2- accept tutoriald commands _ <- forever $ do @@ -51,36 +54,36 @@ websocketProxyServer port host pending = do --figure out why sending three times during startup is necessary sendPromptInfo pInfo conn sendPromptInfo pInfo conn-} - msg <- WS.receiveData conn :: IO T.Text - case parseOnly parseIncomingRequest msg of + msg <- WS.receiveData conn :: IO BS.ByteString + case eitherDecode msg of Left _ -> unexpectedMsg - Right (CreateSessionAtHeadRequest branchName) -> do + Right (CreateSessionAtHeadRequest reqId branchName) -> do ret <- createSessionAtHead dbconn branchName case ret of - Left err -> handleOpResult conn dbconn jsonOnlyPresentation (DisplayErrorResult ("createSessionAtHead error: " <> T.pack (show err))) - - Right (ExecuteTutorialDRequest sessionId presentation tutdString) -> + Left err -> sendResponse conn (RelationalErrorResponse reqId err) + Right sessionId -> sendResponse conn (CreateSessionAtHeadResponse reqId sessionId) + Right (ExecuteTutorialDRequest reqId sessionId presentation (TutorialDText tutdString)) -> case parseTutorialD tutdString of - Left err -> handleOpResult conn dbconn presentation -#if MIN_VERSION_megaparsec(7,0,0) - (DisplayErrorResult - ("parse error: " `T.append` T.pack - (parseErrorPretty . NE.head . bundleErrors $ err))) -#else - (DisplayErrorResult ("parse error: " `T.append` T.pack (parseErrorPretty err))) -#endif + Left err -> do + let parseErr = ParseError $ T.pack + (parseErrorPretty . NE.head . bundleErrors $ err) + + sendResponse conn (RelationalErrorResponse reqId parseErr) Right parsed -> do let timeoutFilter exc = if exc == RequestTimeoutException then Just exc else Nothing responseHandler = do result <- evalTutorialD sessionId dbconn SafeEvaluation parsed - pInfo' <- promptInfo sessionId dbconn - sendPromptInfo pInfo' conn - handleOpResult conn dbconn presentation result - catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn presentation (DisplayErrorResult "Request Timed Out.")) + (headName', schemaName) <- promptInfo sessionId dbconn + sendResponse conn (PromptInfoResponse sessionId headName' schemaName) + let resp = makeResponse reqId presentation result + handleResponse conn dbconn resp + catchJust timeoutFilter responseHandler (\_ -> + sendResponse conn (TimeoutResponse reqId)) pure () + notificationCallback :: WS.Connection -> NotificationCallback notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName, "evaldnotification" .= evaldNotif @@ -90,37 +93,54 @@ notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (o createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection) createConnection wsconn dbname port host = connectProjectM36 (RemoteConnectionInfo dbname host (show port) (notificationCallback wsconn)) -sendError :: (ToJSON a) => WS.Connection -> a -> IO () -sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err])) - -handleOpResult :: WS.Connection -> Connection -> Presentation -> ConsoleResult -> IO () -handleOpResult conn db _ QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db -handleOpResult conn _ _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out])) -handleOpResult _ _ _ (DisplayIOResult ioout) = ioout -handleOpResult conn _ presentation (DisplayErrorResult err) = do - let jsono = ["json" .= err | jsonPresentation presentation] - texto = ["text" .= err | textPresentation presentation] - htmlo = ["html" .= err | htmlPresentation presentation] - WS.sendTextData conn (encode (object ["displayerror" .= object (jsono ++ texto ++ htmlo)])) -handleOpResult conn _ _ (DisplayParseErrorResult _ err) = WS.sendTextData conn (encode (object ["displayparseerrorresult" .= show err])) -handleOpResult conn _ _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True])) -handleOpResult conn _ presentation (DisplayRelationResult rel) = do - let jsono = ["json" .= rel | jsonPresentation presentation] - texto = ["text" .= showRelation rel | textPresentation presentation] - htmlo = ["html" .= relationAsHTML rel | htmlPresentation presentation] - WS.sendTextData conn (encode (object ["displayrelation" .= object (jsono ++ texto ++ htmlo)])) -handleOpResult conn _ presentation (DisplayDataFrameResult df) = do - let jsono = ["json" .= df | jsonPresentation presentation] - texto = ["text" .= showDataFrame df | textPresentation presentation] - htmlo = ["html" .= dataFrameAsHTML df | htmlPresentation presentation] - WS.sendTextData conn (encode (object ["displaydataframe" .= object (jsono ++ texto ++ htmlo)])) -handleOpResult conn _ _ (DisplayRelationalErrorResult relErr) = - WS.sendTextData conn (encode (object ["displayrelationalerrorresult" .= relErr])) -handleOpResult conn dbconn presentation (DisplayHintWith txt conResult) = do - -- we should wrap this up into one response instead of two responses for clarity - WS.sendTextData conn (encode (object ["hint" .= txt])) - handleOpResult conn dbconn presentation conResult - +handleResponse :: WS.Connection -> Connection -> Response -> IO () +handleResponse conn dbconn resp = + case resp of + ConnectionClosedResponse -> do + close dbconn + sendResp + DisplayTextResponse{} -> sendResp + RelationResponse{} -> sendResp + DataFrameResponse{} -> sendResp + CreateSessionAtHeadResponse{} -> sendResp + SuccessResponse{} -> sendResp + TimeoutResponse{} -> sendResp + PromptInfoResponse{} -> sendResp + RelationalErrorResponse{} -> sendResp + TextErrorResponse{} -> sendResp + HintWithResponse{} -> sendResp + where + sendResp = sendResponse conn resp + +makeResponse :: RequestId -> Presentation -> ConsoleResult -> Response +makeResponse reqId presentation consoleResult = + case consoleResult of + QuitResult -> do + ConnectionClosedResponse + DisplayResult out -> + DisplayTextResponse reqId out + DisplayIOResult _ -> + -- we can't send it over the websocket, so just ignore it- in other context, this just used to launch plots + SuccessResponse reqId + DisplayErrorResult err -> + TextErrorResponse reqId err + DisplayParseErrorResult _ err -> + let err' = ParseError $ T.pack (parseErrorPretty . NE.head . bundleErrors $ err) in + RelationalErrorResponse reqId err' + QuietSuccessResult -> + SuccessResponse reqId + DisplayRelationResult rel -> + RelationResponse reqId rel presentation + DisplayDataFrameResult df -> + DataFrameResponse reqId df presentation + DisplayRelationalErrorResult relErr -> + RelationalErrorResponse reqId relErr + DisplayHintWith txt conResult -> + HintWithResponse reqId txt (makeResponse reqId presentation conResult) + +sendResponse :: WS.Connection -> Response -> IO () +sendResponse conn response = + WS.sendBinaryData conn (encode response) -- get current schema and head name for client promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName) @@ -137,6 +157,7 @@ data Presentation = Presentation { jsonPresentation :: Bool, textPresentation :: Bool, htmlPresentation :: Bool } + deriving (Generic, ToJSON, FromJSON) jsonOnlyPresentation :: Presentation jsonOnlyPresentation = Presentation { jsonPresentation = True, @@ -144,16 +165,131 @@ jsonOnlyPresentation = Presentation { jsonPresentation = True, htmlPresentation = False } data PresentationFlag = JSONFlag | TextFlag | HTMLFlag + deriving (Generic, ToJSON, FromJSON) + +newtype RequestId = RequestId UUID.UUID + deriving newtype (ToJSON, FromJSON) + +newtype TutorialDText = TutorialDText T.Text + deriving newtype (ToJSON, FromJSON) + +data ConnectionSetupRequest = ConnectionSetupRequest DatabaseName -data IncomingRequest = ExecuteTutorialDRequest SessionId Presentation T.Text | - CreateSessionAtHeadRequest HeadName +instance FromJSON ConnectionSetupRequest where + parseJSON = withObject "ConnectionSetupRequest" $ \o -> + ConnectionSetupRequest <$> o .: "databaseName" +data Request = ExecuteTutorialDRequest RequestId SessionId Presentation TutorialDText | + CreateSessionAtHeadRequest RequestId HeadName + +data Response = RelationResponse RequestId Relation Presentation | + DataFrameResponse RequestId DataFrame Presentation | + CreateSessionAtHeadResponse RequestId SessionId | + SuccessResponse RequestId | + TimeoutResponse RequestId | + PromptInfoResponse SessionId HeadName SchemaName | + RelationalErrorResponse RequestId RelationalError | + TextErrorResponse RequestId T.Text | + ConnectionClosedResponse | + DisplayTextResponse RequestId T.Text | + HintWithResponse RequestId T.Text Response + +instance ToJSON Request where + toJSON (ExecuteTutorialDRequest reqId sessionId pres tutd) = + object [ + "tag" .= ("ExecuteTutorialDRequest"::T.Text), + "requestId" .= reqId, + "sessionId" .= sessionId, + "presentation" .= pres, + "tutoriald" .= tutd + ] + toJSON (CreateSessionAtHeadRequest reqId headName') = + object [ + "tag" .= ("CreateSessionAtHeadRequest"::T.Text), + "requestId" .= reqId, + "headName" .= headName' + ] + +instance FromJSON Request where + parseJSON = withObject "ExecuteTutorialDRequest" $ \o -> do + tag::T.Text <- o .: "tag" + case tag of + "ExecuteTutorialDRequest" -> + ExecuteTutorialDRequest <$> o .: "requestId" + <*> o .: "sessionId" + <*> o .: "presentation" + <*> o .: "tutoriald" + "CreateSessionAtHeadRequest" -> + CreateSessionAtHeadRequest <$> o .: "requestId" + <*> o .: "headName" + other -> fail ("bad tag: " <> show other) + +instance ToJSON Response where + toJSON (RelationResponse reqId rel presentation) = + object [ "tag" .= ("RelationResult"::T.Text), + "requestId" .= reqId, + "jsonRelation" .= if jsonPresentation presentation then + Just rel else Nothing, + "textRelation" .= if textPresentation presentation then + Just (showRelation rel) else Nothing, + "htmlRelation" .= if htmlPresentation presentation then + Just (relationAsHTML rel) else Nothing + + ] + toJSON (DataFrameResponse reqId df presentation) = + object [ "tag" .= ("DataFrameResponse"::T.Text), + "requestId" .= reqId, + "jsonDataFrame" .= if jsonPresentation presentation then + Just df else Nothing, + "textDataFrame" .= if textPresentation presentation then + Just (showDataFrame df) else Nothing, + "htmlDataFrame" .= if htmlPresentation presentation then + Just (dataFrameAsHTML df) else Nothing + ] + toJSON (CreateSessionAtHeadResponse reqId sessionId) = + object [ "tag" .= ("CreateSessionAtHeadResponse"::T.Text), + "requestId" .= reqId, + "sessionId" .= sessionId ] + toJSON (SuccessResponse reqId) = + object [ "tag" .= ("SuccessResponse"::T.Text), + "requestId" .= reqId ] + toJSON (TimeoutResponse reqId) = + object [ "tag" .= ("TimeoutResponse"::T.Text), + "requestId" .= reqId ] + toJSON (PromptInfoResponse sessionId headName' schemaName) = + object [ "tag" .= ("PromptInfoResponse"::T.Text), + "sessionId" .= sessionId, + "headName" .= headName', + "schemaName" .= schemaName ] + toJSON (RelationalErrorResponse reqId relErr) = + object [ "tag" .= ("RelationalErrorResponse"::T.Text), + "requestId" .= reqId, + "error" .= relErr ] + toJSON (TextErrorResponse reqId err) = + object [ "tag" .= ("TextErrorResponse"::T.Text), + "requestId" .= reqId, + "error" .= err ] + toJSON ConnectionClosedResponse = + object [ "tag" .= ("ConnectionClosedResponse"::T.Text) ] + toJSON (DisplayTextResponse reqId txt) = + object [ "tag" .= ("DisplayTextResponse"::T.Text), + "requestId" .= reqId, + "text" .= txt ] + toJSON (HintWithResponse reqId hintTxt resp) = + object [ "tag" .= ("HintWithResponse"::T.Text), + "requestId" .= reqId, + "hintText" .= hintTxt, + "response" .= resp ] + +{- parseIncomingRequest :: Parser IncomingRequest parseIncomingRequest = parseExecuteTutorialDMessage <|> parseCreateSessionAtHead - +-} +{- parseExecuteTutorialDMessage :: Parser IncomingRequest parseExecuteTutorialDMessage = do + _ <- string "executetutd/" flags <- sepBy ((string "json" $> JSONFlag) <|> (string "text" $> TextFlag) <|> @@ -172,12 +308,15 @@ parseCreateSessionAtHead :: Parser IncomingRequest parseCreateSessionAtHead = do _ <- string "createSessionAtHead:" CreateSessionAtHeadRequest <$> takeText - +-} textToEOFP :: Parser T.Text textToEOFP = T.pack <$> manyTill anyChar endOfInput sessionIdP :: Parser SessionId -sessionIdP = do +sessionIdP = uuidP <* void (char ':') + +uuidP :: Parser UUID.UUID +uuidP = do let hexDigitP = satisfy isHexDigit nHexDigitsP n = T.pack <$> Atto.count n hexDigitP isHexDigit c = (c >= '0' && c <= '9') || From f51b025ccdd44706355a4451bb173c902dd97dba Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 27 Jul 2024 20:26:14 -0400 Subject: [PATCH 151/170] overhaul websocket API refresh websocket client UI resolves #367 --- project-m36.cabal | 2 +- src/bin/ProjectM36/Server/WebSocket.hs | 176 +++++++++------- .../Server/WebSocket/project-m36.js | 197 ++++++++++++++---- .../Server/WebSocket/websocket-client.html | 171 ++++++++++++--- .../Server/WebSocket/websocket-client.js | 128 +++++++++--- .../Server/WebSocket/websocket-config.js | 8 +- test/Server/WebSocket.hs | 55 +++-- 7 files changed, 534 insertions(+), 203 deletions(-) diff --git a/project-m36.cabal b/project-m36.cabal index 11327c6e..a3b95742 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -566,7 +566,7 @@ Test-Suite test-websocket-server import: commontest type: exitcode-stdio-1.0 main-is: Server/WebSocket.hs - Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer + Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter Test-Suite test-isomorphic-schemas import: commontest diff --git a/src/bin/ProjectM36/Server/WebSocket.hs b/src/bin/ProjectM36/Server/WebSocket.hs index 8cb4ab25..12808680 100644 --- a/src/bin/ProjectM36/Server/WebSocket.hs +++ b/src/bin/ProjectM36/Server/WebSocket.hs @@ -19,13 +19,12 @@ import TutorialD.Interpreter import ProjectM36.Interpreter (ConsoleResult(..), SafeEvaluationFlag(..)) import ProjectM36.Client import Control.Exception -import Data.Attoparsec.Text as Atto import Text.Megaparsec.Error -import Data.Functor import Data.Either (fromRight) import qualified Data.ByteString.Lazy as BS import qualified Data.UUID as UUID import GHC.Generics +import qualified Data.Text.Encoding as TE #if MIN_VERSION_megaparsec(7,0,0) import Data.List.NonEmpty as NE @@ -34,12 +33,14 @@ import Data.List.NonEmpty as NE websocketProxyServer :: Port -> Hostname -> WS.ServerApp websocketProxyServer port host pending = do conn <- WS.acceptRequest pending - let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text) + let unexpectedMsg expecting received = do + print (expecting, received) + sendResponse conn (MessageNotExpected expecting) --phase 1- accept database name for connection dbmsg <- WS.receiveData conn :: IO BS.ByteString case eitherDecode dbmsg of Left _ -> do - unexpectedMsg + unexpectedMsg "ConnectionSetupRequest" dbmsg WS.sendClose conn ("" :: T.Text) Right (ConnectionSetupRequest dbname) -> do bracket (createConnection conn dbname port host) @@ -48,6 +49,7 @@ websocketProxyServer port host pending = do Left _ -> pure ()) $ \case Left err -> sendResponse conn (TextErrorResponse (RequestId UUID.nil) (T.pack (show err))) Right dbconn -> do + sendResponse conn ConnectionSetupResponse --phase 2- accept tutoriald commands _ <- forever $ do {-pInfo <- promptInfo sessionId dbconn @@ -56,7 +58,7 @@ websocketProxyServer port host pending = do sendPromptInfo pInfo conn-} msg <- WS.receiveData conn :: IO BS.ByteString case eitherDecode msg of - Left _ -> unexpectedMsg + Left err -> unexpectedMsg "Request" err Right (CreateSessionAtHeadRequest reqId branchName) -> do ret <- createSessionAtHead dbconn branchName case ret of @@ -85,9 +87,8 @@ websocketProxyServer port host pending = do notificationCallback :: WS.Connection -> NotificationCallback -notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName, - "evaldnotification" .= evaldNotif - ])) +notificationCallback conn notifName evaldNotif = + sendResponse conn (NotificationResponse notifName evaldNotif) --this creates a new database for each connection- perhaps not what we want (?) createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection) @@ -109,6 +110,9 @@ handleResponse conn dbconn resp = RelationalErrorResponse{} -> sendResp TextErrorResponse{} -> sendResp HintWithResponse{} -> sendResp + ConnectionSetupResponse{} -> sendResp + NotificationResponse{} -> sendResp + MessageNotExpected{} -> sendResp where sendResp = sendResponse conn resp @@ -140,7 +144,8 @@ makeResponse reqId presentation consoleResult = sendResponse :: WS.Connection -> Response -> IO () sendResponse conn response = - WS.sendBinaryData conn (encode response) + -- this could be optimized to work with a lazy bytestring + WS.sendTextData conn (TE.decodeUtf8 (BS.toStrict (encode response))) -- get current schema and head name for client promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName) @@ -159,6 +164,7 @@ data Presentation = Presentation { htmlPresentation :: Bool } deriving (Generic, ToJSON, FromJSON) + jsonOnlyPresentation :: Presentation jsonOnlyPresentation = Presentation { jsonPresentation = True, textPresentation = False, @@ -168,16 +174,25 @@ data PresentationFlag = JSONFlag | TextFlag | HTMLFlag deriving (Generic, ToJSON, FromJSON) newtype RequestId = RequestId UUID.UUID - deriving newtype (ToJSON, FromJSON) + deriving newtype (ToJSON, FromJSON, Eq, Show) newtype TutorialDText = TutorialDText T.Text deriving newtype (ToJSON, FromJSON) -data ConnectionSetupRequest = ConnectionSetupRequest DatabaseName +newtype ConnectionSetupRequest = ConnectionSetupRequest DatabaseName instance FromJSON ConnectionSetupRequest where - parseJSON = withObject "ConnectionSetupRequest" $ \o -> - ConnectionSetupRequest <$> o .: "databaseName" + parseJSON = withObject "ConnectionSetupRequest" $ \o -> do + tag::T.Text <- o .: "tag" + case tag of + "ConnectionSetupRequest" -> + ConnectionSetupRequest <$> o .: "databaseName" + other -> fail ("bad tag: " <> show other) + +instance ToJSON ConnectionSetupRequest where + toJSON (ConnectionSetupRequest dbName) = + object [ "tag" .= ("ConnectionSetupRequest"::T.Text), + "databaseName" .= dbName ] data Request = ExecuteTutorialDRequest RequestId SessionId Presentation TutorialDText | CreateSessionAtHeadRequest RequestId HeadName @@ -191,24 +206,23 @@ data Response = RelationResponse RequestId Relation Presentation | RelationalErrorResponse RequestId RelationalError | TextErrorResponse RequestId T.Text | ConnectionClosedResponse | + ConnectionSetupResponse | DisplayTextResponse RequestId T.Text | - HintWithResponse RequestId T.Text Response + HintWithResponse RequestId T.Text Response | + NotificationResponse NotificationName EvaluatedNotification | + MessageNotExpected T.Text instance ToJSON Request where - toJSON (ExecuteTutorialDRequest reqId sessionId pres tutd) = - object [ - "tag" .= ("ExecuteTutorialDRequest"::T.Text), - "requestId" .= reqId, - "sessionId" .= sessionId, - "presentation" .= pres, - "tutoriald" .= tutd - ] + toJSON (ExecuteTutorialDRequest reqId sessionId presentation tutd) = + object [ "tag" .= ("ExecuteTutorialDRequest"::T.Text), + "requestId" .= reqId, + "sessionId" .= sessionId, + "presentation" .= presentation, + "tutoriald" .= tutd ] toJSON (CreateSessionAtHeadRequest reqId headName') = - object [ - "tag" .= ("CreateSessionAtHeadRequest"::T.Text), - "requestId" .= reqId, - "headName" .= headName' - ] + object [ "tag" .= ("CreateSessionAtHeadRequest"::T.Text), + "requestId" .= reqId, + "headName" .= headName' ] instance FromJSON Request where parseJSON = withObject "ExecuteTutorialDRequest" $ \o -> do @@ -224,9 +238,53 @@ instance FromJSON Request where <*> o .: "headName" other -> fail ("bad tag: " <> show other) +-- this is useful for Haskell clients to decode JSON messages +instance FromJSON Response where + parseJSON = withObject "Response" $ \o -> do + tag::T.Text <- o .: "tag" + case tag of + "RelationResponse" -> do + mJsonRel <- o .: "jsonRelation" + case mJsonRel of + Nothing -> fail "missing json relation" + Just jsonRel -> + RelationResponse <$> o .: "requestId" <*> pure jsonRel <*> pure jsonOnlyPresentation + "DataFrameResponse" -> do + mJsonDF <- o .: "jsonDataFrame" + case mJsonDF of + Nothing -> fail "missing json dataframe" + Just jsonDF -> + DataFrameResponse <$> o .: "requestId" <*> pure jsonDF <*> pure jsonOnlyPresentation + "CreateSessionAtHeadResponse" -> + CreateSessionAtHeadResponse <$> o .: "requestId" <*> o .: "sessionId" + "SuccessResponse" -> + SuccessResponse <$> o .: "requestId" + "TimeoutResponse" -> + TimeoutResponse <$> o .: "requestId" + "PromptInfoResponse" -> + PromptInfoResponse <$> o .: "sessionId" <*> o .: "headName" <*> o .: "schemaName" + "RelationalErrorResponse" -> + RelationalErrorResponse <$> o .: "requestId" <*> o .: "error" + "TextErrorResponse" -> + TextErrorResponse <$> o .: "requestId" <*> o .: "error" + "ConnectionClosedResponse" -> + pure ConnectionClosedResponse + "DisplayTextResponse" -> + DisplayTextResponse <$> o .: "requestId" <*> o .: "text" + "HintWithResponse" -> + HintWithResponse <$> o .: "requestId" <*> o .: "hintText" <*> o .: "response" + "ConnectionSetupResponse" -> + pure ConnectionSetupResponse + "NotificationResponse" -> + NotificationResponse <$> o .: "notificationName" <*> o .: "evaluatedNotification" + "MessageNotExpected" -> + MessageNotExpected <$> o .: "expected" + other -> + fail ("unexpected tag: " <> T.unpack other) + instance ToJSON Response where toJSON (RelationResponse reqId rel presentation) = - object [ "tag" .= ("RelationResult"::T.Text), + object [ "tag" .= ("RelationResponse"::T.Text), "requestId" .= reqId, "jsonRelation" .= if jsonPresentation presentation then Just rel else Nothing, @@ -280,55 +338,13 @@ instance ToJSON Response where "requestId" .= reqId, "hintText" .= hintTxt, "response" .= resp ] - -{- -parseIncomingRequest :: Parser IncomingRequest -parseIncomingRequest = parseExecuteTutorialDMessage <|> - parseCreateSessionAtHead --} -{- -parseExecuteTutorialDMessage :: Parser IncomingRequest -parseExecuteTutorialDMessage = do - - _ <- string "executetutd/" - flags <- sepBy ((string "json" $> JSONFlag) <|> - (string "text" $> TextFlag) <|> - (string "html" $> HTMLFlag)) "+" - let presentation = foldr (\flag acc -> case flag of - JSONFlag -> acc {jsonPresentation = True} - TextFlag -> acc {textPresentation = True} - HTMLFlag -> acc {htmlPresentation = True}) (Presentation False False False) flags - _ <- char ':' - sessionId <- sessionIdP - _ <- char ':' - tutd <- takeText - pure (ExecuteTutorialDRequest sessionId presentation tutd) - -parseCreateSessionAtHead :: Parser IncomingRequest -parseCreateSessionAtHead = do - _ <- string "createSessionAtHead:" - CreateSessionAtHeadRequest <$> takeText --} -textToEOFP :: Parser T.Text -textToEOFP = T.pack <$> manyTill anyChar endOfInput - -sessionIdP :: Parser SessionId -sessionIdP = uuidP <* void (char ':') - -uuidP :: Parser UUID.UUID -uuidP = do - let hexDigitP = satisfy isHexDigit - nHexDigitsP n = T.pack <$> Atto.count n hexDigitP - isHexDigit c = (c >= '0' && c <= '9') || - (c >= 'a' && c <= 'f') || - (c >= 'A' && c <= 'F') - a <- nHexDigitsP 8 - _ <- char '-' - b <- nHexDigitsP 4 - _ <- char '-' - c <- nHexDigitsP 4 - _ <- char '-' - d <- nHexDigitsP 12 - case UUID.fromText (T.concat [a,b,c,d]) of - Nothing -> fail "invalid UUID" - Just uuid -> pure uuid + toJSON ConnectionSetupResponse = + object [ "tag" .= ("ConnectionSetupResponse"::T.Text), + "status" .= ("ready"::T.Text) ] + toJSON (NotificationResponse notificationName evaldNotification) = + object [ "tag" .= ("NotificationResponse"::T.Text), + "notificationName" .= notificationName, + "evaluatedNotification" .= evaldNotification ] + toJSON (MessageNotExpected expected) = + object [ "tag" .= ("MessageNotExpected"::T.Text), + "expected" .= expected ] diff --git a/src/bin/ProjectM36/Server/WebSocket/project-m36.js b/src/bin/ProjectM36/Server/WebSocket/project-m36.js index 2caf7705..dcd703e0 100644 --- a/src/bin/ProjectM36/Server/WebSocket/project-m36.js +++ b/src/bin/ProjectM36/Server/WebSocket/project-m36.js @@ -10,7 +10,7 @@ * @param {promptCallback} promptCallback - A function called whenever prompt information such as the current schema name and current branch name (if any). * @param {closeCallback} closeCallback - A function called once the connection is closed. */ -var ProjectM36Connection = function (protocol, host, port, path, dbname, openCallback, errorCallback, statusCallback, promptCallback, notificationCallback, closeCallback) { +var ProjectM36Connection = function (protocol, host, port, path, dbname, readyCallback, errorCallback, statusCallback, promptCallback, notificationCallback, closeCallback) { this.protocol = protocol; this.host = host; this.port = port; @@ -28,8 +28,9 @@ var ProjectM36Connection = function (protocol, host, port, path, dbname, openCal var socket = new WebSocket(connectURL); var self = this; socket.onopen = function(event) { - self.socket.send("connectdb:" + self.dbname); - openCallback(event); + const req = {"tag":"ConnectionSetupRequest", + "databaseName":self.dbname} + self.socket.send(JSON.stringify(req)); }; socket.onerror = function(event) { errorCallback(event); @@ -42,15 +43,19 @@ var ProjectM36Connection = function (protocol, host, port, path, dbname, openCal socket.onclose = function(event) { closeCallback(event); }; + this.readycallback = readyCallback; this.statuscallback = statusCallback; this.promptcallback = promptCallback; this.notificationcallback = notificationCallback; this.socket = socket; } -ProjectM36Connection.prototype.createSessionAtHead(branch) +ProjectM36Connection.prototype.createSessionAtHead = function(branch) { - this.socket.send("createSessionAtHead:" + branch) + const req = { "tag" : "CreateSessionAtHeadRequest", + "requestId" : this.makeUUID(), + "headName" : branch }; + this.socket.send(JSON.stringify(req)); } /** @@ -60,14 +65,21 @@ ProjectM36Connection.prototype.createSessionAtHead(branch) * @param {Object} acknowledgementresult - The status update containing an acknowledgement that the query was executed or null. * @param {Object} errorResult - The status update containing the error information or null. */ -var ProjectM36Status = function (relationResult, dataFrameResult, acknowledgementResult, errorResult) +var ProjectM36Status = function (requestId, relationResult, dataFrameResult, acknowledgementResult, errorResult) { + this.requestId = requestId; this.relation = relationResult; this.dataframe = dataFrameResult; this.acknowledgement = acknowledgementResult; this.error = errorResult; } +var ProjectM36SessionCreated = function (requestId, sessionId) +{ + this.requestId = requestId; + this.sessionId = sessionId; +} + ProjectM36Connection.prototype.close = function() { this.socket.close(); @@ -80,56 +92,148 @@ ProjectM36Connection.prototype.readyState = function() ProjectM36Connection.prototype.handleResponse = function(message) { - var relation = message["displayrelation"]; - var dataframe = message["displaydataframe"]; - var acknowledged = message["acknowledged"]; - var error = message["displayerror"]; - var prompt = message["promptInfo"]; - var notification = message["notificationname"] - - if(relation) + if(message.tag == "ConnectionSetupResponse") { - this.statuscallback(new ProjectM36Status(relation['json'], null, null, null)); + this.readycallback(); } - - if(dataframe) + else if(message.tag == "RelationResponse") { - this.statuscallback(new ProjectM36Status(null, dataframe['json'], null, null)); + this.statuscallback(new ProjectM36Status(message.requestId, + message.jsonRelation, + null, + null, + null)); } - - if(acknowledged) + else if(message.tag == "DataFrameResponse") { - this.statuscallback(new ProjectM36Status(null, null, true, null)); + this.statuscallback(new ProjectM36Status(message.requestId, + null, + message.jsonDataFrame, + null, + null)); } - - if(error) + else if(message.tag == "CreateSessionAtHeadResponse") { - if(error.tag) - { - error=error.tag; // for error objects - } - this.statuscallback(new ProjectM36Status(null, null, null, error['json'])); + this.statuscallback(new ProjectM36SessionCreated(message.requestId, + message.sessionId + )); } - - if(prompt) + else if(message.tag == "SuccessResponse") { - this.promptcallback(prompt["headname"], prompt["schemaname"]); + this.statuscallback(new ProjectM36Status(message.requestId, + null, + null, + true, + null)); } - - if(notification) + else if(message.tag == "TimeoutResponse") + { + this.statuscallback(new ProjectM36Status(message.requestId, + null, + null, + 'timeout', + null)); + } + else if(message.tag == "PromptInfoResponse") + { + this.statuscallback(new ProjectM36Status(null, + null, + null, + { "sessionId": message.sessionId, + "headName": message.headName, + "schemaName": message.schemaName }, + null)); + } + else if(message.tag == "RelationalErrorResponse") + { + this.statuscallback(new ProjectM36Status(message.requestId, + null, + null, + null, + message.error.tag + ': ' + message.error.contents)); + } + else if(message.tag == "TextErrorResponse") + { + this.statuscallback(new ProjectM36Status(message.requestId, + null, + null, + null, + message.error)); + } + else if(message.tag == "ConnectionClosedResponse") { - var evaldnotif = message.evaldnotification; - this.notificationcallback(message.notificationname, evaldnotif); + //?? } + else if(message.tag == "DisplayTextResponse") + { + this.statuscallback(new ProjectM36Status(message.requestId, + null, + null, + message.text, + null)); + } + else if(message.tag == "HintWithResponse") + { + this.statuscallback(new ProjectM36Status(message.requestId, + null, + null, + message.hintText, + null)); + this.handleResponse(message.response); + } + else if(message.tag == "NotificationResponse") + { + this.notificationcallback(message.notificationName, message.evaluatedNotification); + } + else if(message.tag == "MessageNotExpected") + { + console.log("message not expected: " + message.expected); + } + else + { + console.log("received unknown message: " + JSON.stringify(message)); + } +} + +// override this is this API is not available in your context +ProjectM36Connection.prototype.makeUUID = function() +{ + return self.crypto.randomUUID() +} + +/** +* Creates a new session which is necessary for executing TutorialD. +* @param {string} branch - The branch of the transaction graph, typically "master". +*/ +ProjectM36Connection.prototype.createSessionAtHead = function(branch) +{ + const requestId = this.makeUUID(); + const req = { "tag": "CreateSessionAtHeadRequest", + "requestId": requestId, + "headName": branch + }; + this.socket.send(JSON.stringify(req)); + return requestId; } /** * Executes a TutorialD string. * @param {string} tutd - The TutorialD string. */ -ProjectM36Connection.prototype.executeTutorialD = function(tutd) +ProjectM36Connection.prototype.executeTutorialD = function(sessionId, tutd) { - this.socket.send("executetutd/json:" + tutd); + const requestId = this.makeUUID(); + const req = { "tag" : "ExecuteTutorialDRequest", + "requestId": requestId, + "sessionId": sessionId, + "presentation": { "jsonPresentation" : true, + "textPresentation" : false, + "htmlPresentation" : false }, + "tutoriald" : tutd + }; + + this.socket.send(JSON.stringify(req)); + return requestId; } /** @@ -153,15 +257,15 @@ ProjectM36Connection.prototype.generateRelationHeader = function(header) { var thead = document.createElement("thead"); var headerrow = document.createElement("tr"); - for(var hindex=0; hindex < header.length; hindex++) + for(var hindex=0; hindex < header.attributes.length; hindex++) { var th = document.createElement("th"); - var attrtype = this.generateAtomType(header[hindex]); + var attrtype = this.generateAtomType(header.attributes[hindex]); th.appendChild(attrtype); headerrow.appendChild(th); } //special case- if there are no attributes (the "true" and "false" relations, then leave a class marker so that the table can be styled to appear regardless - if(header.length == 0) + if(header.attributes.length == 0) { headerrow.setAttribute("class", "emptyrow"); } @@ -171,24 +275,25 @@ ProjectM36Connection.prototype.generateRelationHeader = function(header) ProjectM36Connection.prototype.generateAtomType = function(attr) { - var atomType = attr[1]["tag"]; - var attrName = attr[0]; - var accessory = attr[2]; + var atomType = attr.type.tag; + var attrName = attr.name; + var accessory = attr[2]; //?? var element = document.createElement("span"); element.textContent = attrName + "::"; if (atomType == "RelationAtomType") { + element.textContent += "relation"; var table = document.createElement("table"); element.appendChild(table); var thead = document.createElement("thead"); table.appendChild(thead); var tr = document.createElement("tr"); thead.appendChild(tr); - var relattrs = attr[1]["contents"]; - for(var attrindex = 0; attrindex < relattrs.length; attrindex++) + var relattrs = attr.type.contents; + for(var attrindex = 0; attrindex < relattrs.attributes.length; attrindex++) { var th = document.createElement("th"); - var relattrNode = this.generateAtomType(relattrs[attrindex]); + var relattrNode = this.generateAtomType(relattrs.attributes[attrindex]); th.appendChild(relattrNode); tr.appendChild(th); } diff --git a/src/bin/ProjectM36/Server/WebSocket/websocket-client.html b/src/bin/ProjectM36/Server/WebSocket/websocket-client.html index 1a4e1a51..574aa6c1 100644 --- a/src/bin/ProjectM36/Server/WebSocket/websocket-client.html +++ b/src/bin/ProjectM36/Server/WebSocket/websocket-client.html @@ -1,8 +1,9 @@ + -Project:M36 WebSocket Client +TutorialD WebSocket Client @@ -12,12 +13,13 @@ display: none; } -.deletesection +.deletesection { border: 1px solid; padding: 3px; border-radius: 3px; - background: #ff8b8b; +background: #ff8b8b; + cursor: pointer; } hr @@ -75,7 +77,7 @@ font-family: Courier; } -#samplesouter +#help { border: 1px solid; display: inline-block; @@ -83,24 +85,136 @@ padding-right: 10px; } +#help > details > summary +{ +cursor: pointer; +} + #samples li:hover { - background-color: #d1d1e0; +background-color: #d1d1e0; +cursor: pointer; } #tutd { - width: 300pt; - height: 50pt; + width: 95%; +height: 50pt; +font-size: 12pt; +} + +#tutdcommands +{ +background-color: #80808014; +} + +#console +{ + +} + +#eval +{ + background-color: #0095ff; + border: 1px solid transparent; + border-radius: 3px; + box-shadow: rgba(255, 255, 255, .4) 0 1px 0 0 inset; + box-sizing: border-box; + color: #fff; + cursor: pointer; + display: inline-block; + font-family: -apple-system,system-ui,"Segoe UI","Liberation Sans",sans-serif; + font-size: 12pt; + font-weight: 400; + line-height: 1.15385; + margin: 0; + outline: none; + padding: 8px .8em; + position: relative; + text-align: center; + text-decoration: none; + user-select: none; + -webkit-user-select: none; + touch-action: manipulation; + vertical-align: baseline; + white-space: nowrap; +} + +#eval:disabled +{ + background-color: gray; +} + +#eval:hover:enabled, +#eval:focus:enabled { + background-color: #07c; +} + +#eval:focus:enabled { + box-shadow: 0 0 0 4px rgba(0, 149, 255, .15); +} + +#eval:active:enabled { + background-color: #0064bd; + box-shadow: none; +} + +#poweredby +{ +float:left; +margin-left: 10pt; +margin-top: auto; +margin-bottom: auto; +} + +#title +{ +float: left; +margin-top: 1pt; +} + +#clearer +{ + clear:both; +} + +.copy +{ + cursor: pointer; + border: 1px solid; + padding: 3px; + border-radius: 3px; +} + +.flashupdate +{ +animation-duration: 1s; +animation-name: flash; +animation-iteration-count: 1; +} + +@keyframes flash +{ +from { +background-color: gray; +} +to +{ +background-color: white; +} } -

Project:M36 WebSocket Client

-

This page will allow you to try TutorialD straight from your browser. Try some of the sample queries below.

+

TutorialD Websocket Console

+

powered by Project:M36

+
+
+ TutorialD Console: +
Connect to: -
- + +
-
- Try our 15 minute TutorialD Tutorial or click these sample queries below: - -
    -
  • :showrelvars
    • -
  • :showexpr true
    • -
  • :showexpr false
    • -
  • :importexample cjdate
    • -
  • :showexpr s join sp
    • -
  • update s where city="Paris" (status:=10)
    • -
  • :showexpr s
    • -
  • :commit
    • -
  • :showgraph
    • -
+
+ +
+
+ Help + Try our 15 minute TutorialD Tutorial or click these sample queries below: +
    +
  • :showrelvars
    • +
  • :showexpr true
    • +
  • :showexpr false
    • +
  • :importexample cjdate
    • +
  • :showexpr s join sp
    • +
  • update s where city="Paris" (status:=10)
    • +
  • :showexpr s
    • +
  • :commit
    • +
  • :showgraph
    • +
+
- - + ↻ + ✘
diff --git a/src/bin/ProjectM36/Server/WebSocket/websocket-client.js b/src/bin/ProjectM36/Server/WebSocket/websocket-client.js index 24cf0b51..d4e71ee4 100644 --- a/src/bin/ProjectM36/Server/WebSocket/websocket-client.js +++ b/src/bin/ProjectM36/Server/WebSocket/websocket-client.js @@ -1,52 +1,86 @@ -function appendResult(title, result) +//when we send a request, we generate a pending request block to fill in later when we receive the result +function createPendingResult(requestId, title) { - //prepend the page with an additional relation result var sheet = document.getElementById("sheet"); var template = document.getElementById("sectiontemplate").cloneNode(true); template.removeAttribute("id"); var titleSpan = document.createElement("span"); titleSpan.textContent = title; + template.id = "request-" + requestId template.getElementsByClassName("title")[0].appendChild(titleSpan); - template.getElementsByClassName("result")[0].appendChild(result); - if(result.nodeName == "TABLE") // show some relation statistics - { - var tupleCount = result.querySelectorAll(".result > table > tbody > tr").length - var attrCount = result.querySelectorAll(".result > table > thead > tr > th").length - var attrText = attrCount + " attribute" + (attrCount == 1 ? "" : "s") - var tupleText = tupleCount + " tuple" + (tupleCount == 1 ? "" : "s") - template.getElementsByClassName("relinfo")[0].textContent = attrText + ", " + tupleText; - } + template.getElementsByClassName("result")[0].textContent = 'Request Pending'; var interactor = document.getElementById("interactor"); sheet.insertBefore(template, interactor); window.scrollTo(0,document.body.scrollHeight); + +} + +function appendResult(requestId, title, result) +{ + if(requestId) + { + const requestResult = document.getElementById("request-" + requestId); + if(!requestResult) + { + //throw new Error('Failed to find pending request block'); + console.log('Failed to find pending request block'); + } + const resultEl = requestResult.getElementsByClassName("result")[0]; + resultEl.textContent=''; + resultEl.appendChild(result); + if(result.nodeName == "TABLE") // show some relation statistics + { + var tupleCount = result.querySelectorAll(".result > table > tbody > tr").length + var attrCount = result.querySelectorAll(".result > table > thead > tr > th").length + var attrText = attrCount + " attribute" + (attrCount == 1 ? "" : "s") + var tupleText = tupleCount + " tuple" + (tupleCount == 1 ? "" : "s") + requestResult.getElementsByClassName("relinfo")[0].textContent = attrText + ", " + tupleText; + window.scrollTo(0,document.body.scrollHeight); + } + } + else //message without a pending result such as connection error + { + //make up a request id + const reqId = conn.makeUUID(); + createPendingResult(reqId, 'Error'); + appendResult(reqId, 'Error', result); + } } function updateStatus(status) { var tutd = document.getElementById("tutd").value; - if(status.relation) + if(status instanceof ProjectM36SessionCreated) + { + sessionId = status.sessionId; + } + else if(status.relation) { var relastable = conn.generateRelation(status.relation); - appendResult(tutd, relastable); + appendResult(status.requestId, tutd, relastable); mungeEmptyRows(); } - if(status.dataframe) + else if(status.dataframe) { var dataframeastable = conn.generateDataFrame(status.dataframe); - appendResult(tutd, dataframeastable); + appendResult(status.requestId, tutd, dataframeastable); mungeEmptyRows(); } - if(status.acknowledgement) + else if(status.acknowledgement) { var ok = document.createElement("span"); - ok.textContent="OK"; - appendResult(tutd, ok); + ok.textContent="ok"; + appendResult(status.requestId, tutd, ok); } - if(status.error) + else if(status.error) { var error = document.createElement("span"); error.textContent=status.error; - appendResult(tutd, error); + appendResult(status.requestId, tutd, error); + } + else + { + throw new Error('unknown status') } } @@ -126,7 +160,7 @@ function connectOrDisconnect(form) conninfo.textContent = "Connected to:"; window.conn = new ProjectM36Connection(protocol, host, port, path, dbname, - connectionOpened, + connectionReady, connectionError, updateStatus, promptUpdate, @@ -141,7 +175,7 @@ function connectionError(event) { var err = document.createElement("span"); err.textContent = "Failed to connect to websocket server. Please check the connection parameters and try again."; - appendResult("Connect", err); + appendResult(null, "Connect", err); connectionClosed(event) } @@ -157,10 +191,12 @@ function toggleConnectionFields(form, enabled, status) form.elements["port"], form.elements["dbname"], form.elements["path"]]; + const console = document.getElementById('tutd'); var disableElements = [form.elements["protocol"], - ] - var enableElements = [document.getElementById("eval")]; + console] + var enableElements = [document.getElementById("eval"),console]; + for(var ein=0; ein < readonlyElements.length; ein++) { var e = readonlyElements[ein]; @@ -206,11 +242,14 @@ function toggleConnectionFields(form, enabled, status) } -function connectionOpened(event) +function connectionReady(event) { toggleConnectionFields(document.getElementById("connection"), false, "Disconnect"); + conn.createSessionAtHead("master"); } +var sessionId = null; + function execTutorialD() { var tutd = document.getElementById("tutd").value; @@ -218,11 +257,13 @@ function execTutorialD() { var err = document.createElement("span"); err.textContent = "Cannot execute command until a database connection is established."; - appendResult(tutd, err); + appendResult(null,tutd, err); } else { - conn.executeTutorialD(tutd); + const requestId = conn.executeTutorialD(sessionId, tutd); + createPendingResult(requestId, tutd); + } return false; } @@ -241,7 +282,8 @@ function installSampleHandlers() var tutd = document.getElementById("tutd"); var el = samples[idx]; el.onclick = function(el) { - tutd.value = el.target.textContent; + tutd.value = el.target.textContent; + flashtutd(); } } } @@ -260,3 +302,33 @@ function pageload() installSampleHandlers(); setupDefaultConfig(); } + +function copyTutorialD(el) +{ + const expr = el.parentNode.getElementsByClassName('title')[0].textContent; + const console = document.getElementById("tutd"); + console.value = expr; + flashtutd() +} + +function flashtutd() +{ + const console = document.getElementById("tutd"); + console.classList.remove('flashupdate'); + void console.offsetWidth; + console.classList.add('flashupdate'); +} + +function toggleHelp() +{ + const collapser = document.getElementById("helpcollapsible"); + if(collapser.style.visibility == 'visible') + { + collapser.style.visibility = 'hidden'; + } + else + { + collapser.style.visibility = 'visible'; + } +} + diff --git a/src/bin/ProjectM36/Server/WebSocket/websocket-config.js b/src/bin/ProjectM36/Server/WebSocket/websocket-config.js index be401ffd..07118e30 100644 --- a/src/bin/ProjectM36/Server/WebSocket/websocket-config.js +++ b/src/bin/ProjectM36/Server/WebSocket/websocket-config.js @@ -1,5 +1,5 @@ -var defaultConfig = { 'protocol': 'wss', - 'host': 'try.project-m36.io', - 'port': '', +var defaultConfig = { 'protocol': 'ws', + 'host': 'localhost', + 'port': '8000', 'path': 'ws/', - 'dbname': 'test' } \ No newline at end of file + 'dbname': 'test' } diff --git a/test/Server/WebSocket.hs b/test/Server/WebSocket.hs index b98a55a0..45295a2f 100644 --- a/test/Server/WebSocket.hs +++ b/test/Server/WebSocket.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TypeApplications #-} -- test the websocket server import Test.HUnit import qualified Network.WebSockets as WS @@ -6,7 +6,6 @@ import ProjectM36.Server.WebSocket import ProjectM36.Server.Config import ProjectM36.Server import ProjectM36.Client -import ProjectM36.Base import Network.Socket import Control.Exception @@ -15,10 +14,10 @@ import System.Exit import Data.Typeable import Data.Text hiding (map) import Data.Aeson -import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS import ProjectM36.Relation import Control.Monad (void) +import Data.UUID.V4 (nextRandom) --start the websocket server -- run some tutoriald against it @@ -75,35 +74,55 @@ basicConnection :: PortNumber -> WS.ClientApp () -> IO () basicConnection port = WS.runClient "127.0.0.1" (fromIntegral port) "/" basicConnectionWithDatabase :: PortNumber -> DatabaseName -> WS.ClientApp () -> IO () -basicConnectionWithDatabase port dbname block = basicConnection port (\conn -> do - WS.sendTextData conn ("connectdb:" `append` pack dbname) - block conn) +basicConnectionWithDatabase port dbname block = basicConnection port + (\conn -> do + --setup connection + let connectMsg = encode (ConnectionSetupRequest dbname) + WS.sendTextData conn connectMsg + setupResponse <- WS.receiveData conn + case eitherDecode setupResponse of + Left err -> error (show err) + Right ConnectionSetupResponse{} -> pure () + Right _other -> error (show setupResponse) + block conn) testBasicConnection :: PortNumber -> DatabaseName -> Test -testBasicConnection port _ = TestCase $ basicConnection port (\conn -> WS.sendClose conn ("test close"::Text)) +testBasicConnection port _ = TestCase $ basicConnection port (\conn -> WS.sendClose conn (""::Text)) testTutorialD :: PortNumber -> DatabaseName -> Test testTutorialD port dbname = TestCase $ basicConnectionWithDatabase port dbname testtutd where discardPromptInfo conn = do response <- WS.receiveData conn :: IO BS.ByteString - let decoded = decode response :: Maybe (M.Map Text (M.Map Text Text)) - case decoded of - Just _ -> pure () - Nothing -> assertFailure ("failed to decode prompt info: " ++ show response) + case eitherDecode @Response response of + Right _promptInfo -> pure () + Left err -> assertFailure ("failed to decode prompt info: " ++ err ++ ": " ++ show response) testtutd conn = do - discardPromptInfo conn - WS.sendTextData conn ("executetutd/json:" `append` ":showexpr true") - discardPromptInfo conn + -- create new session at master + reqId <- RequestId <$> nextRandom + let createSessionMsg = encode (CreateSessionAtHeadRequest reqId "master") + WS.sendTextData conn createSessionMsg + sessionResponse <- WS.receiveData conn :: IO BS.ByteString + sessionId <- case eitherDecode sessionResponse of + Left err -> assertFailure err + Right (CreateSessionAtHeadResponse reqId' sid) -> do + assertEqual "request ID round-trip" reqId' reqId + pure sid + Right _other -> assertFailure ("expected session response but got: " <> show sessionResponse) + -- send tutd message + reqIdB <- RequestId <$> nextRandom + let tutdMsg = encode (ExecuteTutorialDRequest reqIdB sessionId jsonOnlyPresentation (TutorialDText ":showexpr true")) + WS.sendTextData conn tutdMsg discardPromptInfo conn --receive relation response response <- WS.receiveData conn :: IO BS.ByteString - let decoded = decode response :: Maybe (M.Map Text (M.Map Text Relation)) + let decoded = decode @Response response case decoded of Nothing -> assertFailure "failed to decode" - Just decoded' -> do - assertEqual "round-trip true relation" ((decoded' M.! "displayrelation") M.! "json") relationTrue - WS.sendClose conn ("test close" :: Text) + Just (RelationResponse _ trueRel _) -> do + assertEqual "round-trip true relation" trueRel relationTrue + WS.sendClose conn ("" :: Text) + Just _other -> assertFailure ("unexpected response: " <> show response) From 63a57b3fe20d58ebe695791ea29ea5aecfe26aa1 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 27 Jul 2024 21:05:48 -0400 Subject: [PATCH 152/170] update stack deps for streamly 0.10.1 --- stack.ghc9.2.yaml | 8 ++++---- stack.ghc9.4.yaml | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/stack.ghc9.2.yaml b/stack.ghc9.2.yaml index 92b64d88..f40f7b57 100644 --- a/stack.ghc9.2.yaml +++ b/stack.ghc9.2.yaml @@ -3,10 +3,10 @@ packages: - "." extra-deps: - - streamly-0.9.0 - - streamly-core-0.1.0 - - streamly-bytestring-0.2.0 - - curryer-rpc-0.3.2 + - streamly-0.10.1 + - streamly-core-0.2.2 + - streamly-bytestring-0.2.2 + - curryer-rpc-0.3.6 - fast-builder-0.1.2.1 - rset-1.0.0 - winery-1.4 diff --git a/stack.ghc9.4.yaml b/stack.ghc9.4.yaml index 3655a136..18426519 100644 --- a/stack.ghc9.4.yaml +++ b/stack.ghc9.4.yaml @@ -3,10 +3,10 @@ packages: - "." extra-deps: - - streamly-0.9.0 - - streamly-core-0.1.0 - - streamly-bytestring-0.2.0 - - curryer-rpc-0.3.2 + - streamly-0.10.1 + - streamly-core-0.2.2 + - streamly-bytestring-0.2.2 + - curryer-rpc-0.3.6 - fast-builder-0.1.2.1 - rset-1.0.0 - winery-1.4 From 47c88479f5b88db3ad909f5055b29a36445764d2 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 27 Jul 2024 22:07:31 -0400 Subject: [PATCH 153/170] increment version to 1.0.2 --- Changelog.markdown | 6 ++++++ project-m36.cabal | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/Changelog.markdown b/Changelog.markdown index 2c718839..b0db278f 100644 --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,9 @@ +# 2024-07-27 (v1.0.2) + +* upgrade to streamly 0.10.1 +* refactor websocket API to support request UUIDs (#367) +* refactor websocket API to support `createSessionAtHead` (#367) + # 2024-07-15 (v1.0.1) * add support for aggregate functions using sub-relation attributes diff --git a/project-m36.cabal b/project-m36.cabal index 2055a8fc..993bb1e0 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 1.0.1 +Version: 1.0.2 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple From e0127e0ec853892bb66a9451d1b3e9cc611d68df Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 27 Jul 2024 23:26:04 -0400 Subject: [PATCH 154/170] fix misreported prompt info message --- .../ProjectM36/Server/WebSocket/project-m36.js | 17 ++++++++++------- .../Server/WebSocket/websocket-client.html | 2 +- .../Server/WebSocket/websocket-client.js | 4 ++++ 3 files changed, 15 insertions(+), 8 deletions(-) diff --git a/src/bin/ProjectM36/Server/WebSocket/project-m36.js b/src/bin/ProjectM36/Server/WebSocket/project-m36.js index dcd703e0..a583c262 100644 --- a/src/bin/ProjectM36/Server/WebSocket/project-m36.js +++ b/src/bin/ProjectM36/Server/WebSocket/project-m36.js @@ -80,6 +80,13 @@ var ProjectM36SessionCreated = function (requestId, sessionId) this.sessionId = sessionId; } +var ProjectM36PromptInfo = function(headName, schemaName, sessionId) +{ + this.headName = headName; + this.schemaName = schemaName; + this.sessionId = sessionId; +} + ProjectM36Connection.prototype.close = function() { this.socket.close(); @@ -136,13 +143,9 @@ ProjectM36Connection.prototype.handleResponse = function(message) } else if(message.tag == "PromptInfoResponse") { - this.statuscallback(new ProjectM36Status(null, - null, - null, - { "sessionId": message.sessionId, - "headName": message.headName, - "schemaName": message.schemaName }, - null)); + this.statuscallback(new ProjectM36PromptInfo(message.headName, + message.schemaName, + message.sessionId)); } else if(message.tag == "RelationalErrorResponse") { diff --git a/src/bin/ProjectM36/Server/WebSocket/websocket-client.html b/src/bin/ProjectM36/Server/WebSocket/websocket-client.html index 574aa6c1..3ffc19a1 100644 --- a/src/bin/ProjectM36/Server/WebSocket/websocket-client.html +++ b/src/bin/ProjectM36/Server/WebSocket/websocket-client.html @@ -230,8 +230,8 @@

powered by Pr

- + diff --git a/src/bin/ProjectM36/Server/WebSocket/websocket-client.js b/src/bin/ProjectM36/Server/WebSocket/websocket-client.js index d4e71ee4..9c64335b 100644 --- a/src/bin/ProjectM36/Server/WebSocket/websocket-client.js +++ b/src/bin/ProjectM36/Server/WebSocket/websocket-client.js @@ -54,6 +54,10 @@ function updateStatus(status) { sessionId = status.sessionId; } + else if(status instanceof ProjectM36PromptInfo) + { + promptUpdate(status.headName, status.schemaName); + } else if(status.relation) { var relastable = conn.generateRelation(status.relation); From 84071e1126218e8fb7f9e46011aa410276932ac5 Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 2 Aug 2024 08:57:18 -0400 Subject: [PATCH 155/170] fix typo in on_null.markdown --- docs/on_null.markdown | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/on_null.markdown b/docs/on_null.markdown index b138b954..aa5fe4e6 100644 --- a/docs/on_null.markdown +++ b/docs/on_null.markdown @@ -344,7 +344,7 @@ But all we have really done is add even more NULLs. Retrieving a sensible value ## Runtime Types -Project:M36 supports management of new algebraic data types at runtime. These types are associated with transactions and can changed over time whereas primitive Atoms cannot be changed. +Project:M36 supports management of new algebraic data types at runtime. These types are associated with transactions and can change over time whereas primitive Atoms cannot be changed. ``` TutorialD (master/main): data Age = PreciseAge Int | ForgotToAsk | RefusedToDisclose | NotApplicable | ApproximateAge Int Int From e78ce7b26e9de17374f9571fd967edb31c3cda60 Mon Sep 17 00:00:00 2001 From: AgentM Date: Fri, 2 Aug 2024 22:08:50 -0400 Subject: [PATCH 156/170] add reference to TutorialD course under Community README --- README.markdown | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.markdown b/README.markdown index 8158ace6..fba1c62d 100644 --- a/README.markdown +++ b/README.markdown @@ -45,6 +45,8 @@ Project:M36 supports multiple frontends which target different audiences. ## Community +* [TutorialD for SQL Developers](https://www.udemy.com/course/tutoriald-for-sql-developers/) + * ask in IRC channel for discount code to get free access * [Developer's Blog](https://agentm.github.io/project-m36/) * [Mailing List/Discussion Group](https://groups.google.com/d/forum/project-m36) * IRC Channel: irc.libera.chat #project-m36 -- [Chat via Web Client](http://kiwiirc.com/nextclient/irc.libera.chat:+6697/#project-m36) From 5e2ee14611a5e88699e8921a27376e7fcced136d Mon Sep 17 00:00:00 2001 From: Recursion Ninja Date: Mon, 12 Aug 2024 17:32:14 -0400 Subject: [PATCH 157/170] Adding compatibility for GHC 9.6, GHC 9.8, and GHC 9.10 --- .github/workflows/ci.yaml | 3 + .github/workflows/haskell-ci.yml | 15 ++ Changelog.markdown | 29 ++-- cabal.project | 41 +++++- examples/Plantfarm.hs | 46 +++--- examples/SimpleClient.hs | 5 +- examples/blog.hs | 2 +- project-m36.cabal | 36 +++-- .../Interpreter/RODatabaseContextOperator.hs | 5 + src/bin/benchmark/bigrel.hs | 5 +- src/lib/ProjectM36/AtomFunction.hs | 10 +- src/lib/ProjectM36/AtomType.hs | 11 +- src/lib/ProjectM36/AttributeNames.hs | 5 +- src/lib/ProjectM36/Client.hs | 5 +- src/lib/ProjectM36/Client/Simple.hs | 3 + src/lib/ProjectM36/DataTypes/SQL/Null.hs | 15 +- src/lib/ProjectM36/DatabaseContextFunction.hs | 10 +- src/lib/ProjectM36/Error.hs | 6 +- src/lib/ProjectM36/Function.hs | 10 +- src/lib/ProjectM36/GraphRefRelationalExpr.hs | 11 +- src/lib/ProjectM36/IsomorphicSchema.hs | 89 ++++++----- src/lib/ProjectM36/Relation.hs | 10 +- src/lib/ProjectM36/Relation/Show/Term.hs | 8 +- src/lib/ProjectM36/RelationalExpression.hs | 25 +++- src/lib/ProjectM36/SQL/Convert.hs | 3 + src/lib/ProjectM36/ScriptSession.hs | 80 +++++++--- src/lib/ProjectM36/StaticOptimizer.hs | 13 +- src/lib/ProjectM36/TransactionGraph.hs | 138 +++++++++--------- src/lib/ProjectM36/TransactionGraph/Merge.hs | 5 + .../ProjectM36/TransactionGraph/Persist.hs | 8 +- src/lib/ProjectM36/Tuple.hs | 27 ++-- src/lib/ProjectM36/TupleSet.hs | 7 +- 32 files changed, 432 insertions(+), 254 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index ad41733f..3b28ab9a 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -37,6 +37,9 @@ jobs: ghc_version: - 9.2 - 9.4 + - 9.6 + - 9.8 + - 9.10 include: - os: macos-latest ghc_version: 9.2 diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 145f9dc2..77a04e34 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -28,6 +28,21 @@ jobs: strategy: matrix: include: + - compiler: ghc-9.10.1 + compilerKind: ghc + compilerVersion: 9.10.1 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.8.2 + compilerKind: ghc + compilerVersion: 9.8.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.6.6 + compilerKind: ghc + compilerVersion: 9.6.6 + setup-method: ghcup + allow-failure: false - compiler: ghc-9.4.8 compilerKind: ghc compilerVersion: 9.4.8 diff --git a/Changelog.markdown b/Changelog.markdown index b0db278f..ed5fc5b4 100644 --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,8 @@ +# 2024-87-12 (v1.1.0) + +* add support for GHC 9.6, GHC 9.8, and GHC 9.10 +* clean up compiler warnings + # 2024-07-27 (v1.0.2) * upgrade to streamly 0.10.1 @@ -17,33 +22,33 @@ * revert to using streamly 0.9.0 due to over-the-wire corruption bug in 0.10.0 * fixed toAtom/fromAtom for NonEmpty lists (#363) - + # 2023-12-30 (v0.9.8) * fix notification serialization in transaction (#362) * require minimum GHC 9.2 (dropping GHC 8.10 and GHC 9.0) * add support for GHC 9.4 - + # 2023-07-18 (v0.9.7) * fix critical bug resulting in empty results from cross joins - + # 2022-11-05 (v0.9.6) * fix tuple context passed down to extended expressions * add ddl hash- useful for validating that the client supports the current schema * add registered queries- useful for constraining what DDL can be applied to the database so as not to break client applications * reduce memory usage during Merkle hashing by an order of magnitude by using strict serialization and hashing - + # 2022-08-19 (v0.9.5) - + * removed necessity for caret "^" when using boolean atom expressions in restriction predicates * `True` and `False` are now value constructors for `Bool` atom values (previously `t` and `f); changed for better discoverability by Haskell developers * add `Scientific` data type for arbitrary-precision values (backed by Data.Scientific) * add support for GHC 9.0 and GHC 9.2 * drop support for GHC < 8.10.7 * fix relational equality when the relation includes a nested relation - + # 2021-12-05 (v0.9.4) * fix bug which [caused tuple storage to be duplicated unnecessarily](https://github.com/agentm/project-m36/pull/328) @@ -54,11 +59,11 @@ * fix constraint checking after undefining a relation variable * optionally allow TLS and client certificate authentication in Project:M36 server * require GHC >=8.8 - + # 2021-04-01 (v0.9.3) -* add new ":importtutd " feature to import TutorialD from a local file or a HTTP/HTTPS URI - +* add new ":importtutd " feature to import TutorialD from a local file or a HTTP/HTTPS URI + # 2020-12-27 (v0.9.0) * replace unmaintained distributed-process-client-server RPC package with new curryer RPC package @@ -97,7 +102,7 @@ * fix atom function type validation * add support for GHC 8.4 (now we support GHC 8.0, 8.2, and 8.4) - + # 2018-08-10 (v0.5) * fix critical type bug which allowed unresolved types to be used @@ -124,8 +129,8 @@ * alter websocket server API to allow for multiple representations (JSON, text, or HTML) to be selected and returned simultaneously * add jupyter kernel for TutorialD interpreter -* fix warnings suggested by new hlint 2.0.10 - +* fix warnings suggested by new hlint 2.0.10 + # 2017-10-08 (v0.3) * replaced overuse of `undefined` with `Proxy` in `Tupleable` and `Atomable` typeclasses diff --git a/cabal.project b/cabal.project index 6bf8b77e..d6ed5aeb 100644 --- a/cabal.project +++ b/cabal.project @@ -4,5 +4,42 @@ packages: package * split-sections: True --- allow fast-builder to build with GHC 9.2.2 (currently pegged at 9.0.1) -allow-newer: fast-builder:base +-- Required patch from head.hackage to fix: +-- * `winery` compilation with GHC-9.6 +-- * `barbies-th` compilation with GHC-9.8 +if impl(ghc >= 9.6) + repository head.hackage.ghc.haskell.org + url: https://ghc.gitlab.haskell.org/head.hackage/ + secure: True + key-threshold: 3 + root-keys: + 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329 + 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d + f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89 + +-- Loosened dependency bounds for compatibility with various versions of GHC. +-- Remove these upper bound relaxations once the dependency has a new version +-- released with higher upper bounds. +-- +-- Note: The 'allow-newer' fields are /concatenative/, meaning that each +-- conditional statement which is satisfied will have thier listed packages +-- unioned together into an aggregated set of 'allow-newer' packages constraints. +-- Hence the 'allow-newer' constraints /accumulate/ as GHC versions increase. +if impl(ghc >= 9.6) + allow-newer: + barbies-th:base, + barbies-th:template-haskell, + fast-builder:base, + +if impl(ghc >= 9.8) + allow-newer: + curryer-rpc:base, + streamly-bytestring:bytestring, + +if impl(ghc >= 9.10) + allow-newer: + streamly:base, + streamly:template-haskell, + streamly-core:base, + streamly-core:template-haskell, + websockets:containers, diff --git a/examples/Plantfarm.hs b/examples/Plantfarm.hs index e4e23943..950b1785 100644 --- a/examples/Plantfarm.hs +++ b/examples/Plantfarm.hs @@ -1,11 +1,21 @@ {-# LANGUAGE DeriveGeneric #-} - {-# LANGUAGE OverloadedStrings #-} - {-# LANGUAGE DeriveAnyClass #-} - {-# LANGUAGE DerivingVia #-} - +-- The calls to 'S.raise' from the @scotty@ package are /deprecated/ +-- TODO: +-- Replace 'raise' with 'throw' +-- +-- Until then, supproess the deprecation warning +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module Main + ( main + -- * Other example exports + , closeConn + , getAllPlantsWith + , update + , updatePlant + ) where import Codec.Winery (Serialise, WineryVariant(WineryVariant)) import Control.DeepSeq (NFData) @@ -90,7 +100,7 @@ instance S.Parsable Stage where | otherwise = Left t --- Just for ToJSON for ilustration of stage +-- Just for ToJSON for illustration of stage type ASCIIStage = String seedStr :: ASCIIStage @@ -147,7 +157,7 @@ main = do -- retrieve a plant by name S.get "/plant/:name" $ do - n <- S.param "name" + n <- S.pathParam "name" e <- liftIO $ getPlant c n p <- handleWebError e S.json p @@ -170,12 +180,12 @@ main = do -- watering the plant having the provided name. -- This will water the plant and might let it progress to the next stage. It might also die. S.post "/plant/water/:name" $ do - n <- S.param "name" + n <- S.pathParam "name" e <- liftIO $ waterPlant c n p <- handleWebError e S.json p - -- retriving all the plants as json data + -- retrieving all the plants as json data S.get "/plants" $ do e <- liftIO $ getAllPlants c ps <- handleWebErrors e @@ -190,14 +200,14 @@ main = do -- deleting all plants at a specific stage S.delete "/plants?stage=:stage" $ do - s <- S.param "stage" + s <- S.pathParam "stage" e <- liftIO $ deletePlantsByStage c s p <- handleWebError e S.json p -- deleting all plants at a specific stage S.delete "/plants" $ do - s <- S.param "name" + s <- S.pathParam "name" e <- liftIO $ deletePlantByName c s p <- handleWebError e S.json p @@ -209,14 +219,14 @@ main = do S.json ps handleWebError :: Either Err b -> S.ActionM b -handleWebError (Left e) = S.raise (TL.pack $ "An error occurred:\n" <> show e) +handleWebError (Left e) = S.raise . TL.pack $ "An error occurred:\n" <> show e handleWebError (Right v) = pure v handleWebErrors :: [Either Err b] -> S.ActionM [b] handleWebErrors e = do case lefts e of [] -> pure (rights e) - l -> S.raise (TL.pack $ "Errors occurred:\n" <> concatMap ((<>"\n") . show) l) + l -> S.raise . TL.pack $ "Errors occurred:\n" <> concatMap ((<> "\n") . show) l -- | watering a plant and thereby possibly updating its stage @@ -264,7 +274,7 @@ data Err = NotSpecified | NotFound deriving (Show ,Generic) instance ToJSON Err --- | Just for convinience for passing around the SessionId +-- | Just for convenience for passing around the SessionId -- and the Connection data DBConnection = DB SessionId Connection @@ -337,7 +347,7 @@ createSchema (DB sessionId conn) = do _ <- handleIOErrorsAndQuit $ mapM (executeDatabaseContextExpr sessionId conn) [ toAddTypeExpr (Proxy :: Proxy Stage) -- Adds the Type Stage as data to the DB , toDefineExpr (Proxy :: Proxy Plant) "plants" -- Creates the plants relation - , databaseContextExprForUniqueKey "plants" ["name"] -- Makes name of the plants relation a uniqe Key, + , databaseContextExprForUniqueKey "plants" ["name"] -- Makes name of the plants relation a unique Key, -- Foreign Key restrictions are available too ] pure () @@ -358,7 +368,7 @@ dbConnection = do let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext -- The code below persists the data in a DB with the name "base". \\ -- let connInfo = InProcessConnectionInfo (CrashSafePersistence "base") emptyNotificationCallback [] \\ - -- In addition minimal persistance is available. \\ + -- In addition minimal persistence is available. \\ -- let connInfo = InProcessConnectionInfo (MinimalPersistence "base") emptyNotificationCallback [] conn <- handleIOErrorAndQuit $ connectProjectM36 connInfo --create a database session at the default branch of the database @@ -371,7 +381,7 @@ insert :: (Tupleable a, Traversable t) => DBConnection -> t a -> Base.RelVarName insert db rlv rlvName = executeWithTransaction db $ toInsertExpr rlv rlvName -- | A polymorphic function to update data in the DB. --- An update in one funtion would take: +-- An update in one function would take: -- -- - SessionId -- - Connection @@ -388,9 +398,9 @@ update db rlv attr rlvName = executeWithTransaction db $ toUpdateExpr rlvName at delete :: (Tupleable a) => DBConnection -> a -> [AttributeName]-> Base.RelVarName -> IO (Either Err ()) delete db rlv attr rlvName = executeWithTransaction db $ toDeleteExpr rlvName attr rlv --- | A convenience function to make executing DBContextExpr with commiting simpler. \\ +-- | A convenience function to make executing DBContextExpr with committing simpler. \\ -- In particular for expr that just insert, delete and update. --- Therefor ultimately return Either _ () +-- Therefore ultimately return Either _ () executeWithTransaction :: DBConnection -> Either RelationalError DatabaseContextExpr -> IO (Either Err ()) executeWithTransaction (DB sid conn) expr = do iEx <- handleError expr diff --git a/examples/SimpleClient.hs b/examples/SimpleClient.hs index 907877ee..4ea8f90c 100644 --- a/examples/SimpleClient.hs +++ b/examples/SimpleClient.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- This suppresses the incomplete pattern match on @(Right tupSet)@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} import ProjectM36.Client import ProjectM36.TupleSet import ProjectM36.Relation.Show.Term @@ -7,7 +10,7 @@ main :: IO () main = do -- 1. create a ConnectionInfo let connInfo = RemoteConnectionInfo "mytestdb" "127.0.0.1" (show defaultServerPort) emptyNotificationCallback - -- 2. conncted to the remote database + -- 2. connected to the remote database eConn <- connectProjectM36 connInfo case eConn of Left err -> print err diff --git a/examples/blog.hs b/examples/blog.hs index 5538ee93..60857fc0 100644 --- a/examples/blog.hs +++ b/examples/blog.hs @@ -27,7 +27,7 @@ import Web.Scotty as S import Text.Blaze.Html5 (h1, h2, h3, p, form, input, (!), toHtml, Html, a, toValue, hr, textarea) import Text.Blaze.Html5.Attributes (name, href, type_, method, action, value) import Text.Blaze.Html.Renderer.Text -import Control.Monad.IO.Class (liftIO) +--import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status import Data.Time.Format.ISO8601 diff --git a/project-m36.cabal b/project-m36.cabal index 993bb1e0..50f66c86 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 1.0.2 +Version: 1.1.0 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple @@ -13,7 +13,7 @@ Maintainer: agentm@themactionfaction.com Synopsis: Relational Algebra Engine Description: A relational algebra engine which can be used to persist and query Haskell data types. Extra-Source-Files: Changelog.markdown README.markdown scripts/DateExamples.tutd scripts/multiline.tutd -tested-with: GHC ==9.2.8 || ==9.4.8 +tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 Source-Repository head Type: git @@ -37,7 +37,7 @@ Flag haskell-scripting Library Build-Depends: - base>=4.16 && < 4.19, + base >=4.14 && < 5, ghc-paths, mtl, containers, @@ -98,7 +98,7 @@ Library fast-builder, scientific if flag(haskell-scripting) - Build-Depends: ghc >= 9.0 && < 9.5 + Build-Depends: ghc >= 9.0 CPP-Options: -DPM36_HASKELL_SCRIPTING if impl(ghc>= 8) && flag(haskell-scripting) build-depends: @@ -213,7 +213,9 @@ Library Other-Modules: ProjectM36.Win32Handle else --219- too many exported symbols under Windows and GHC 8.4 - GHC-Options: -rdynamic -fexternal-interpreter -eventlog + GHC-Options: -rdynamic -fexternal-interpreter + if impl(ghc <9.4) + GHC-Options: -eventlog C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c Build-Depends: unix CC-Options: -fPIC @@ -225,7 +227,7 @@ Library Executable tutd if flag(haskell-scripting) - Build-Depends: ghc >= 9.0 && < 9.5 + Build-Depends: ghc >= 9.0 Build-Depends: base >=4.8, ghc-paths, project-m36, @@ -291,10 +293,11 @@ Executable tutd ProjectM36.Interpreter main-is: TutorialD/tutd.hs CC-Options: -fPIC - if os(windows) - GHC-Options: -Wall -threaded -eventlog -rtsopts - else - GHC-Options: -Wall -threaded -rdynamic -eventlog -rtsopts + GHC-Options: -Wall -threaded -rtsopts + if !os(windows) + GHC-Options: -rdynamic + if impl(ghc <9.4) + GHC-Options: -eventlog if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded Hs-Source-Dirs: ./src/bin @@ -303,7 +306,7 @@ Executable tutd Executable sqlegacy if flag(haskell-scripting) - Build-Depends: ghc >= 9.0 && < 9.5 + Build-Depends: ghc >= 9.0 Build-Depends: base, ghc-paths, project-m36, @@ -377,7 +380,7 @@ Executable sqlegacy Executable project-m36-server if flag(haskell-scripting) - Build-Depends: ghc >= 9.0 && < 9.5 + Build-Depends: ghc >= 9.0 Build-Depends: base, ghc-paths, transformers, @@ -428,7 +431,9 @@ Executable bigrel GHC-Options: -Wall -threaded -rtsopts HS-Source-Dirs: ./src/bin if flag(profiler) - GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall -eventlog + GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall + if impl(ghc <9.4) + GHC-Prof-Options: -eventlog Common commontest Default-Language: Haskell2010 @@ -548,7 +553,10 @@ benchmark ondiskclient import: commontest type: exitcode-stdio-1.0 main-is: benchmark/OnDiskClient.hs - GHC-Options: -rtsopts -Wall -threaded -eventlog -finfo-table-map -fdistinct-constructor-tables + GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall + GHC-Options: -rtsopts -Wall -threaded -finfo-table-map -fdistinct-constructor-tables + if impl(ghc <9.4) + GHC-Options: -eventlog Test-Suite test-server import: commontest diff --git a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs index ecf31116..abcae1c9 100644 --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} module TutorialD.Interpreter.RODatabaseContextOperator where import ProjectM36.Base @@ -12,7 +13,11 @@ import TutorialD.Interpreter.Base import TutorialD.Interpreter.RelationalExpr import TutorialD.Interpreter.DatabaseContextExpr import TutorialD.Printer +#if MIN_VERSION_base(4,18,0) +import Control.Monad (when) +#else import Control.Monad.State +#endif import qualified Data.Text as T import ProjectM36.Relation.Show.Gnuplot import ProjectM36.HashSecurely diff --git a/src/bin/benchmark/bigrel.hs b/src/bin/benchmark/bigrel.hs index 9d23b15e..b957a8df 100755 --- a/src/bin/benchmark/bigrel.hs +++ b/src/bin/benchmark/bigrel.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleInstances, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +-- This suppresses the incomplete pattern match on @Right x@ in 'matrixRun' +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} import ProjectM36.Base import ProjectM36.Relation import ProjectM36.DateExamples @@ -111,7 +113,7 @@ vectorMatrixRun = do -- 20 s 90 MBs- a clear win- ideal size is 10 * 100000 * 8 bytes = 80 MB! without IntAtom wrapper --with IntAtom wrapper: 1m12s 90 MB -{- +{- vectorMatrixRelation :: Int -> Int -> HS.HashSet (V.Vector Atom) vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount] @@ -129,4 +131,3 @@ matrixRelation attributeCount tupleCount = do tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom (fromIntegral tupleX))) tuples = map tuple [0 .. tupleCount] mkRelationDeferVerify attrs (RelationTupleSet tuples) - diff --git a/src/lib/ProjectM36/AtomFunction.hs b/src/lib/ProjectM36/AtomFunction.hs index 72166a15..ce8b0ae9 100644 --- a/src/lib/ProjectM36/AtomFunction.hs +++ b/src/lib/ProjectM36/AtomFunction.hs @@ -18,12 +18,10 @@ foldAtomFuncType foldType returnType = returnType] atomFunctionForName :: FunctionName -> AtomFunctions -> Either RelationalError AtomFunction -atomFunctionForName funcName' funcSet = if HS.null foundFunc then - Left $ NoSuchFunctionError funcName' - else - Right $ head $ HS.toList foundFunc - where - foundFunc = HS.filter (\f -> funcName f == funcName') funcSet +atomFunctionForName funcName' funcSet = + case HS.toList $ HS.filter (\f -> funcName f == funcName') funcSet of + [] -> Left $ NoSuchFunctionError funcName' + x : _ -> Right x -- | Create a junk named atom function for use with searching for an already existing function in the AtomFunctions HashSet. emptyAtomFunction :: FunctionName -> AtomFunction diff --git a/src/lib/ProjectM36/AtomType.hs b/src/lib/ProjectM36/AtomType.hs index 91eec9db..0d68fd89 100644 --- a/src/lib/ProjectM36/AtomType.hs +++ b/src/lib/ProjectM36/AtomType.hs @@ -13,7 +13,11 @@ import qualified Data.Set as S import qualified Data.List as L import Data.Maybe (isJust) import Data.Either (rights, lefts) +#if MIN_VERSION_ghc(9,6,0) +import Control.Monad (foldM, unless, when) +#else import Control.Monad.Writer +#endif import qualified Data.Map as M import qualified Data.Text as T @@ -416,10 +420,9 @@ resolveFunctionReturnValue funcName' tvMap ctype@(ConstructedAtomType tCons retM pure ctype else do let diff = M.difference retMap tvMap - if M.null diff then - pure (ConstructedAtomType tCons (M.intersection tvMap retMap)) - else - Left (AtomFunctionTypeVariableResolutionError funcName' (fst (head (M.toList diff)))) + case M.toList diff of + [] -> pure (ConstructedAtomType tCons (M.intersection tvMap retMap)) + x : _ -> Left (AtomFunctionTypeVariableResolutionError funcName' (fst x)) resolveFunctionReturnValue funcName' tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName' tvName) Just typ -> pure typ diff --git a/src/lib/ProjectM36/AttributeNames.hs b/src/lib/ProjectM36/AttributeNames.hs index 7991ffd2..58b25c63 100644 --- a/src/lib/ProjectM36/AttributeNames.hs +++ b/src/lib/ProjectM36/AttributeNames.hs @@ -1,7 +1,10 @@ module ProjectM36.AttributeNames where import ProjectM36.Base import qualified Data.Set as S -import Data.List (foldl') +#if MIN_VERSION_base(4,20,0) +#else +import Data.Foldable (foldl') +#endif --AttributeNames is a data structure which can represent inverted projection attributes and attribute names derived from relational expressions empty :: AttributeNamesBase a diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs index 8c8e6093..11cc98e8 100644 --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -122,7 +122,10 @@ import ProjectM36.Key import qualified ProjectM36.DataFrame as DF import ProjectM36.DatabaseContextFunction as DCF import qualified ProjectM36.IsomorphicSchema as Schema -import Control.Monad.State +#if MIN_VERSION_base(4,16,0) +import Control.Monad (forever, forM, forM_, unless, void) +#endif +--import Control.Monad.State import qualified ProjectM36.RelationalExpression as RE import qualified ProjectM36.TransactionGraph as Graph import ProjectM36.TransactionGraph as TG diff --git a/src/lib/ProjectM36/Client/Simple.hs b/src/lib/ProjectM36/Client/Simple.hs index a09d55d9..def7d575 100644 --- a/src/lib/ProjectM36/Client/Simple.hs +++ b/src/lib/ProjectM36/Client/Simple.hs @@ -31,6 +31,9 @@ module ProjectM36.Client.Simple ( ) where import Control.Exception.Base +#if MIN_VERSION_ghc(9,6,0) +import Control.Monad ((<=<)) +#endif import Control.Monad.Reader import ProjectM36.Base import qualified ProjectM36.Client as C diff --git a/src/lib/ProjectM36/DataTypes/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs index 6996dbca..f9c54d77 100644 --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -298,9 +298,18 @@ sqlNullableIntegerToMaybe _ = Nothing sqlEqualsTypes :: Atom -> Atom -> Bool sqlEqualsTypes a b = underlyingType a == underlyingType b where - underlyingType (ConstructedAtom "SQLNull" (ConstructedAtomType "SQLNullable" typmap) []) | M.size typmap == 1 = snd (head (M.assocs typmap)) - underlyingType (ConstructedAtom "SQLJust" (ConstructedAtomType "SQLNullable" typmap) _args) | M.size typmap == 1 = snd (head (M.assocs typmap)) - underlyingType atom = atomTypeForAtom atom + underlyingType atom = + let def = atomTypeForAtom atom + in case atom of + ConstructedAtom x (ConstructedAtomType "SQLNullable" typmap) y -> + let getSingle = case M.elems typmap of + [z] -> z + _ -> def + in case (x, y) of + ("SQLNull", []) -> getSingle + ("SQLJust", _) -> getSingle + _ -> def + _ -> def sqlEquals :: AtomFunctionBodyType sqlEquals [a,b] | sqlEqualsTypes a b = diff --git a/src/lib/ProjectM36/DatabaseContextFunction.hs b/src/lib/ProjectM36/DatabaseContextFunction.hs index c8f42e0b..c52d47a1 100644 --- a/src/lib/ProjectM36/DatabaseContextFunction.hs +++ b/src/lib/ProjectM36/DatabaseContextFunction.hs @@ -24,12 +24,10 @@ emptyDatabaseContextFunction name = Function { } databaseContextFunctionForName :: FunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction -databaseContextFunctionForName funcName' funcs = if HS.null foundFunc then - Left $ NoSuchFunctionError funcName' - else - Right (head (HS.toList foundFunc)) - where - foundFunc = HS.filter (\f -> funcName f == funcName') funcs +databaseContextFunctionForName funcName' funcs = + case HS.toList $ HS.filter (\f -> funcName f == funcName') funcs of + [] -> Left $ NoSuchFunctionError funcName' + x : _ -> Right x evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext evalDatabaseContextFunction func args ctx = diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs index 2d8ff4ec..cb1d72fe 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -125,10 +125,8 @@ data PersistenceError = InvalidDirectoryError FilePath | --collapse list of errors into normal error- if there is just one, just return one someErrors :: [RelationalError] -> RelationalError someErrors [] = error "no errors in error list: function misuse" -someErrors errList = if length errList == 1 then - head errList - else - MultipleErrors errList +someErrors [err] = err +someErrors errList = MultipleErrors errList data MergeError = SelectedHeadMismatchMergeError | PreferredHeadMissingMergeError HeadName | diff --git a/src/lib/ProjectM36/Function.hs b/src/lib/ProjectM36/Function.hs index 0aff5118..881a63c8 100644 --- a/src/lib/ProjectM36/Function.hs +++ b/src/lib/ProjectM36/Function.hs @@ -52,9 +52,7 @@ loadFunctions _ _ _ _ = pure (Left LoadSymbolError) #endif functionForName :: FunctionName -> HS.HashSet (Function a) -> Either RelationalError (Function a) -functionForName funcName' funcSet = if HS.null foundFunc then - Left $ NoSuchFunctionError funcName' - else - Right $ head $ HS.toList foundFunc - where - foundFunc = HS.filter (\f -> funcName f == funcName') funcSet +functionForName funcName' funcSet = + case HS.toList $ HS.filter (\f -> funcName f == funcName') funcSet of + [] -> Left $ NoSuchFunctionError funcName' + x : _ -> Right x diff --git a/src/lib/ProjectM36/GraphRefRelationalExpr.hs b/src/lib/ProjectM36/GraphRefRelationalExpr.hs index 2e874ce0..d85f40eb 100644 --- a/src/lib/ProjectM36/GraphRefRelationalExpr.hs +++ b/src/lib/ProjectM36/GraphRefRelationalExpr.hs @@ -24,12 +24,11 @@ instance Monoid SingularTransactionRef where -- | return `Just transid` if this GraphRefRelationalExpr refers to just one transaction in the graph. This is useful for determining if certain optimizations can apply. singularTransaction :: Foldable t => t GraphRefTransactionMarker -> SingularTransactionRef -singularTransaction expr - | S.null transSet = NoTransactionsRef - | S.size transSet == 1 = SingularTransactionRef (head (S.toList transSet)) - | otherwise = MultipleTransactionsRef - where - transSet = foldr S.insert S.empty expr +singularTransaction expr = case S.toList $ foldr S.insert S.empty expr of + [] -> NoTransactionsRef + x : xs -> case xs of + [] -> SingularTransactionRef x + _ -> MultipleTransactionsRef -- | Return True if two 'GraphRefRelationalExpr's both refer exclusively to the same transaction (or none at all). inSameTransaction :: GraphRefRelationalExpr -> GraphRefRelationalExpr -> Maybe GraphRefTransactionMarker diff --git a/src/lib/ProjectM36/IsomorphicSchema.hs b/src/lib/ProjectM36/IsomorphicSchema.hs index a59fb20e..847043b2 100644 --- a/src/lib/ProjectM36/IsomorphicSchema.hs +++ b/src/lib/ProjectM36/IsomorphicSchema.hs @@ -32,7 +32,7 @@ import Data.Monoid data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs | RemoveSubschema SchemaName deriving (Generic, Show) - + isomorphs :: Schema -> SchemaIsomorphs isomorphs (Schema i) = i @@ -40,10 +40,13 @@ isomorphs (Schema i) = i -- A schema is fully isomorphic iff all relvars in the base context are in the "out" relvars, but only once. --TODO: add relvar must appear exactly once constraint validateSchema :: Schema -> DatabaseContext -> Maybe SchemaError -validateSchema potentialSchema baseContext | not (S.null rvDiff) = Just (RelVarReferencesMissing rvDiff) - | not (null outDupes) = Just (RelVarOutReferencedMoreThanOnce (head outDupes)) - | not (null inDupes) = Just (RelVarInReferencedMoreThanOnce (head inDupes)) - | otherwise = Nothing +validateSchema potentialSchema baseContext + | not (S.null rvDiff) = Just (RelVarReferencesMissing rvDiff) + | otherwise = case outDupes of + x : _ -> Just $ RelVarOutReferencedMoreThanOnce x + _ -> case inDupes of + [] -> Nothing + x : _ -> Just $ RelVarInReferencedMoreThanOnce x where --check that the predicate for IsoUnion and IsoRestrict holds right now outDupes = duplicateNames (namesList isomorphOutRelVarNames) @@ -70,8 +73,8 @@ isomorphsInRelVarNames :: SchemaIsomorphs -> S.Set RelVarName isomorphsInRelVarNames morphs = S.fromList (foldr rvnames [] morphs) where rvnames morph acc = acc ++ isomorphInRelVarNames morph - -isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName] + +isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName] isomorphOutRelVarNames (IsoRestrict _ _ (rvA, rvB)) = [rvA, rvB] isomorphOutRelVarNames (IsoUnion _ _ rv) = [rv] isomorphOutRelVarNames (IsoRename _ rv) = [rv] @@ -89,23 +92,23 @@ validateRelationalExprInSchema schema relExprIn = ex -> Right ex) relExprIn where validRelVarNames = isomorphsInRelVarNames (isomorphs schema) - + processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr processRelationalExprInSchema (Schema []) expr = pure expr processRelationalExprInSchema schema relExprIn = do --validate that all rvs are present in the virtual schema- this prevents relation variables being referenced in the underlying schema (falling through the transformation) let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr - validateRelationalExprInSchema schema relExprIn + validateRelationalExprInSchema schema relExprIn foldM processRelExpr relExprIn (isomorphs schema) -validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError () +validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError () validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema) - -processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr + +processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr processDatabaseContextExprInSchema schema@(Schema morphs) dbExpr = do let relExprMogrifier = processRelationalExprInSchema schema --validate that all mentioned relvars are in the valid set - _ <- validateDatabaseContextExprInSchema schema dbExpr + _ <- validateDatabaseContextExprInSchema schema dbExpr --perform the morph foldM (\ex morph -> databaseContextExprMorph morph relExprMogrifier ex) dbExpr morphs @@ -120,18 +123,18 @@ processDatabaseContextExprSchemaUpdate schema@(Schema morphs) expr = case expr o where validSchemaName = isomorphsInRelVarNames morphs passthru rvname = Schema (morphs ++ [IsoRename rvname rvname]) - -processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas + +processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas processDatabaseContextExprSchemasUpdate subschemas expr = M.map (`processDatabaseContextExprSchemaUpdate` expr) subschemas - --- re-evaluate- it's not possible to display an incdep that may be for a foreign key to a relvar which is not available in the subschema! + +-- re-evaluate- it's not possible to display an incdep that may be for a foreign key to a relvar which is not available in the subschema! -- weird compromise: allow inclusion dependencies failures not in the subschema to be propagated- in the worst case, only the inclusion dependency's name is leaked. {- -- | Convert inclusion dependencies for display in a specific schema. applySchemaToInclusionDependencies :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies -applySchemaToInclusionDependencies (Schema morphs) incDeps = +applySchemaToInclusionDependencies (Schema morphs) incDeps = let incDepMorph incDep = --check that the mentioned relvars are in fact in the current schema - M.update incDepMorph incDeps + M.update incDepMorph incDeps -} -- | Morph a relational expression in one schema to another isomorphic schema. @@ -144,7 +147,7 @@ relExprMorph (IsoRestrict relIn _ (relOutTrue, relOutFalse)) = \case RelationVariable rv m | rv == relIn -> Right (Union (RelationVariable relOutTrue m) (RelationVariable relOutFalse m)) orig -> Right orig relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \case - --only the true predicate portion appears in the virtual schema + --only the true predicate portion appears in the virtual schema RelationVariable rv m | rv == relInT -> Right (Restrict predi (RelationVariable relTarget m)) RelationVariable rv m | rv == relInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget m)) @@ -152,7 +155,7 @@ relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \case relExprMorph (IsoRename relIn relOut) = \case RelationVariable rv m | rv == relIn -> Right (RelationVariable relOut m) orig -> Right orig - + relExprMogrify :: (RelationalExprBase a -> Either RelationalError (RelationalExprBase a)) -> RelationalExprBase a -> Either RelationalError (RelationalExprBase a) relExprMogrify func (Project attrs expr) = func expr >>= \ex -> func (Project attrs ex) relExprMogrify func (Union exprA exprB) = do @@ -187,7 +190,7 @@ spam :: Either RelationalError RelationalExpr spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate (Just "nonboss", Just "boss"))) (RelationVariable "emp" ()) spam2 :: Either RelationalError RelationalExpr -spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ()) +spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ()) -} databaseContextExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr) -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr @@ -208,14 +211,14 @@ databaseContextExprMorph iso@(IsoRestrict rvIn filt (rvTrue, rvFalse)) relExprFu falseExpr n = Update n attrMap (AndPredicate predi (NotPredicate filt)) pure (MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]) MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs - orig -> pure orig -databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) relExprFunc expr = case expr of + orig -> pure orig +databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) relExprFunc expr = case expr of --assign: replace all instances in the portion of the target relvar with the new tuples from the relExpr --problem: between the delete->insert, constraints could be violated which would not otherwise be violated in the "in" schema. This implies that there should be a combo operator which can insert/update/delete in a single pass based on relexpr queries, or perhaps MultipleExpr should be the infamous "comma" operator from TutorialD? -- if any tuples are filtered out of the insert/assign, we need to simulate a constraint violation Assign rv relExpr | rv == rvTrue -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut filt, Insert rvOut (Restrict filt ex)] - Assign rv relExpr | rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt), + Assign rv relExpr | rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt), Insert rvOut (Restrict (NotPredicate filt) ex)] Insert rv relExpr | rv == rvTrue || rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ Insert rvOut ex Delete rv delPred | rv == rvTrue -> pure $ Delete rvOut (AndPredicate delPred filt) @@ -229,9 +232,9 @@ databaseContextExprMorph iso@(IsoRename relIn relOut) relExprFunc expr = case ex Insert rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure $ Insert relOut ex Delete rv delPred | rv == relIn -> pure $ Delete relOut delPred Update rv attrMap predi | rv == relIn -> pure $ Update relOut attrMap predi - MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs + MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs orig -> pure orig - + -- | Apply the isomorphism transformations to the relational expression to convert the relational expression from operating on one schema to a disparate, isomorphic schema. applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> Either RelationalError RelationalExpr applyRelationalExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs @@ -243,7 +246,7 @@ inclusionDependencyInSchema :: Schema -> InclusionDependency -> Either Relationa inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do --collect all relvars which appear in the schema let schemaRelVars = isomorphsInRelVarNames (isomorphs schema) - rvAssoc <- mapM (\rvIn -> do + rvAssoc <- mapM (\rvIn -> do rvOut <- processRelationalExprInSchema schema (RelationVariable rvIn ()) pure (rvOut, RelationVariable rvIn ()) ) @@ -262,7 +265,7 @@ inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do -- for IsoRestrict, consider hiding the two, generated constraints since they can never be thrown in the isomorphic schema inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies inclusionDependenciesInSchema schema incDeps = M.fromList <$> mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps) - + relationVariablesInSchema :: Schema -> Either RelationalError RelationVariables relationVariablesInSchema schema@(Schema morphs) = foldM transform M.empty morphs where @@ -289,7 +292,7 @@ relationVariablesAsRelationInSchema concreteDbContext schema graph = do attrs = A.attributesFromList [Attribute "name" TextAtomType, Attribute "attributes" (RelationAtomType subrelAttrs)] relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributesVec (attributes rel))] - attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))] + attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))] attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of Left err -> error ("relationVariablesAsRelation pooped " ++ show err) Right rel -> RelationAtom rel @@ -297,12 +300,12 @@ relationVariablesAsRelationInSchema concreteDbContext schema graph = do {- proposal -data DatabaseContext = +data DatabaseContext = Concrete ...| Virtual Isomorphs -} -{- -applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables +{- +applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables applyRelationVariablesSchemaIsomorphs {-morphs rvs -}= undefined -} {- M.fromList <$> mapM (\(rvname, rvexpr) -> do @@ -321,10 +324,10 @@ applySchemaIsomorphsToDatabaseContext morphs context = do --notifications = notifs, --typeConstructorMapping = tconsmapping }) - -} -{- + -} +{- validate :: SchemaIsomorph -> S.Set RelVarName -> Either RelationalError SchemaIsomorph -validate morph underlyingRvNames = if S.size invalidRvNames > 0 then +validate morph underlyingRvNames = if S.size invalidRvNames > 0 then Left (MultipleErrors (map RelVarNotDefinedError (S.toList invalidRvNames))) else Right morph @@ -335,7 +338,7 @@ validate morph underlyingRvNames = if S.size invalidRvNames > 0 then -- | Create inclusion dependencies mainly for IsoRestrict because the predicate should hold in the base schema. createIncDepsForIsomorph :: SchemaName -> SchemaIsomorph -> InclusionDependencies -createIncDepsForIsomorph sname (IsoRestrict origRv predi (rvTrue, rvFalse)) = let +createIncDepsForIsomorph sname (IsoRestrict origRv predi (rvTrue, rvFalse)) = let newIncDep predicate rv = InclusionDependency (Project AN.empty (Restrict predicate (RelationVariable rv ()))) (ExistingRelation relationTrue) incDepName b = "schema" <> "_" <> sname <> "_" <> b in M.fromList [(incDepName (origRv <> "_true"), newIncDep predi rvTrue), @@ -358,7 +361,7 @@ evalSchemaExpr (AddSubschema sname morphs) context transId graph sschemas = dbenv = mkDatabaseContextEvalEnv transId graph dbstate <- runDatabaseContextEvalMonad context dbenv (evalGraphRefDatabaseContextExpr incDepExprs) pure (newSchemas, dbc_context dbstate) ---need to propagate dirty flag here +--need to propagate dirty flag here evalSchemaExpr (RemoveSubschema sname) context _ _ sschemas = if M.member sname sschemas then pure (M.delete sname sschemas, context) @@ -373,14 +376,14 @@ class Morph a where instance Morph RelationalExpr where morphToSchema schema _ relExprIn = do let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr - validateRelationalExprInSchema schema relExprIn + validateRelationalExprInSchema schema relExprIn foldM processRelExpr relExprIn (isomorphs schema) -- | The names of inclusion dependencies might leak context about a different schema, but that's arbitrary and cannot be altered without having the user provide a renaming function or a new set of incDep names- seems extraneous. instance Morph InclusionDependency where morphToSchema schema _ (InclusionDependency rexprA rexprB) = do let schemaRelVars = isomorphsInRelVarNames (isomorphs schema) - rvAssoc <- mapM (\rvIn -> do + rvAssoc <- mapM (\rvIn -> do rvOut <- processRelationalExprInSchema schema (RelationVariable rvIn ()) pure (rvOut, RelationVariable rvIn ()) ) @@ -400,7 +403,7 @@ instance Morph InclusionDependencies where -- cannot be implemented because relvars map to transaction-graph-traversing expressions and we do not track schema changes over time instance Morph RelationVariables where morphToSchema schema tg relVars = do - let folder acc (IsoRename rvBase rvSchema) = + let folder acc (IsoRename rvBase rvSchema) = case M.lookup rvBase relVars of Nothing -> Left (RelVarNotDefinedError rvBase) Just gfExpr -> do @@ -412,7 +415,3 @@ instance Morph RelationVariables where instance Morph GraphRefRelationalExpr where -- cannot be supported because we don't track how the schema changes over the lifetime of a transaction graph -} - - - - diff --git a/src/lib/ProjectM36/Relation.hs b/src/lib/ProjectM36/Relation.hs index b01687c5..1f72f344 100644 --- a/src/lib/ProjectM36/Relation.hs +++ b/src/lib/ProjectM36/Relation.hs @@ -73,10 +73,12 @@ relationFalse = Relation A.emptyAttributes emptyTupleSet --if the relation contains one tuple, return it, otherwise Nothing singletonTuple :: Relation -> Maybe RelationTuple -singletonTuple rel@(Relation _ tupleSet) = if cardinality rel == Finite 1 then - Just $ head $ asList tupleSet - else - Nothing +singletonTuple rel@(Relation _ tupleSet) = + case cardinality rel of + Countable -> Nothing + _ -> case asList tupleSet of + [] -> Nothing + x : _ -> Just x -- this is still unncessarily expensive for (bigx union bigx) because each tuple is hashed and compared for equality (when the hashes match), but the major expense is attributesEqual, but we already know that all tuple attributes are equal (it's a precondition) union :: Relation -> Relation -> Either RelationalError Relation diff --git a/src/lib/ProjectM36/Relation/Show/Term.hs b/src/lib/ProjectM36/Relation/Show/Term.hs index c01eaf1b..3a6e972b 100644 --- a/src/lib/ProjectM36/Relation/Show/Term.hs +++ b/src/lib/ProjectM36/Relation/Show/Term.hs @@ -136,9 +136,11 @@ renderBody :: [[Cell]] -> ([Int],[Int]) -> StringType renderBody cellMatrix cellLocs = renderRows `T.append` renderBottomBar where columnLocations = fst cellLocs - rowLocations = snd cellLocs - renderRows = T.concat (map (\(row, rowHeight)-> renderRow row columnLocations rowHeight boxV) rowHeightMatrix) - rowHeightMatrix = zip cellMatrix (tail rowLocations) + rowLocations = case snd cellLocs of + [] -> [] + _ : xs -> xs + renderRows = T.concat (map (\(row, rowHeight) -> renderRow row columnLocations rowHeight boxV) rowHeightMatrix) + rowHeightMatrix = zip cellMatrix rowLocations renderBottomBar = renderHBar boxBL boxBB boxBR columnLocations repeatString :: Int -> StringType -> StringType diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index bd6e2ff2..1984789d 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -22,7 +22,16 @@ import qualified ProjectM36.Attribute as A import qualified Data.Map as M import qualified Data.HashSet as HS import qualified Data.Set as S +#if MIN_VERSION_ghc(9,6,0) +import Control.Monad (foldM, unless, when) +import Control.Monad.State +import Control.Monad.Except +import Control.Monad.Reader as R +#else import Control.Monad.State hiding (join) +import Control.Monad.Except hiding (join) +import Control.Monad.Reader as R hiding (join) +#endif import Data.Bifunctor (second) import Data.Maybe import Data.Tuple (swap) @@ -36,9 +45,7 @@ import qualified Data.Vector as V import qualified ProjectM36.TypeConstructorDef as TCD import qualified Control.Monad.RWS.Strict as RWS import Control.Monad.RWS.Strict (RWST, execRWST, runRWST) -import Control.Monad.Except hiding (join) import Control.Monad.Trans.Except (except) -import Control.Monad.Reader as R hiding (join) import ProjectM36.NormalizeExpr import ProjectM36.WithNameExpr import ProjectM36.Function @@ -1138,7 +1145,9 @@ evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do Nothing -> pure Nothing tuples <- evalGraphRefTupleExprs mAttrs tupleExprs let attrs = fromMaybe firstTupleAttrs mAttrs - firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples) + firstTupleAttrs = case tuples of + [] -> A.emptyAttributes + x : _ -> tupleAttributes x lift $ except $ mkRelation attrs (RelationTupleSet tuples) evalGraphRefRelationalExpr (MakeStaticRelation attributeSet tupleSet) = lift $ except $ mkRelation attributeSet tupleSet @@ -1215,12 +1224,12 @@ transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError transactionForId tid graph | tid == U.nil = Left RootTransactionTraversalError - | S.null matchingTrans = - Left $ NoSuchTransactionError tid | otherwise = - Right $ head (S.toList matchingTrans) - where - matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph) + let sameTID (Transaction idMatch _ _) = idMatch == tid + matchingTrans = S.filter sameTID $ transactionsForGraph graph + in case S.toList matchingTrans of + [] -> Left $ NoSuchTransactionError tid + x : _ -> Right x typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs index c1aafafe..1858d058 100644 --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -32,7 +32,10 @@ import Control.Monad.Trans.State (StateT, get, put, runStateT, evalStateT) import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Trans.Class (lift) +#if MIN_VERSION_base(4,20,0) +#else import Data.Foldable (foldl') +#endif import Data.Bifunctor (bimap) --import qualified Data.HashSet as HS diff --git a/src/lib/ProjectM36/ScriptSession.hs b/src/lib/ProjectM36/ScriptSession.hs index ee7dadb6..2834ed90 100644 --- a/src/lib/ProjectM36/ScriptSession.hs +++ b/src/lib/ProjectM36/ScriptSession.hs @@ -22,14 +22,30 @@ import System.Environment import Unsafe.Coerce import GHC.LanguageExtensions (Extension(OverloadedStrings,ExtendedDefaultRules,ImplicitPrelude,ScopedTypeVariables)) - +#if MIN_VERSION_ghc(9,6,0) +import Data.List.NonEmpty(NonEmpty(..)) +#else +#endif +#if MIN_VERSION_ghc(9,6,0) +#else +#endif +#if MIN_VERSION_ghc(9,6,0) +import GHC.Core.TyCo.Compare (eqType) +#elif MIN_VERSION_ghc(9,0,0) +import GHC.Core.Type (eqType) +#else +import Type (eqType) +#endif +#if MIN_VERSION_ghc(9,6,0) +#elif MIN_VERSION_ghc(9,0,0) +import GHC.Unit.Types (IsBootInterface(NotBoot)) +#else +#endif #if MIN_VERSION_ghc(9,4,0) import GHC.Utils.Panic (handleGhcException) import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) import GHC.Types.SourceText (SourceText(NoSourceText)) -import GHC.Unit.Types (IsBootInterface(NotBoot)) import GHC.Driver.Ppr (showSDocForUser) -import GHC.Core.Type (eqType) import GHC.Core.TyCo.Ppr (pprType) import GHC.Utils.Encoding (zEncodeString) import GHC.Unit.State (emptyUnitState) @@ -39,9 +55,7 @@ import GHC.Types.PkgQual (RawPkgQual(NoRawPkgQual)) import GHC.Utils.Panic (handleGhcException) import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) import GHC.Types.SourceText (SourceText(NoSourceText)) -import GHC.Unit.Types (IsBootInterface(NotBoot)) import GHC.Driver.Ppr (showSDocForUser) -import GHC.Core.Type (eqType) import GHC.Types.TyThing.Ppr (pprTypeForUser) import GHC.Utils.Encoding (zEncodeString) import GHC.Unit.State (emptyUnitState) @@ -50,8 +64,6 @@ import GHC.Unit.State (emptyUnitState) import GHC.Utils.Panic (handleGhcException) import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) import GHC.Types.Basic (SourceText(NoSourceText)) -import GHC.Unit.Types (IsBootInterface(NotBoot)) -import GHC.Core.Type (eqType) import GHC.Utils.Outputable (showSDocForUser) import GHC.Utils.Encoding (zEncodeString) import GHC.Core.Ppr.TyThing (pprTypeForUser) @@ -60,7 +72,6 @@ import GHC.Core.Ppr.TyThing (pprTypeForUser) import BasicTypes (SourceText(NoSourceText)) import Outputable (showSDocForUser) import PprTyThing (pprTypeForUser) -import Type (eqType) import Encoding (zEncodeString) import Panic (handleGhcException) import DynFlags (projectVersion, PkgConfRef(PkgConfFile), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming), PackageDBFlag(PackageDB)) @@ -126,7 +137,9 @@ initScriptSession ghcPkgPaths = do let localPkgPaths = map pkgConf (ghcPkgPaths ++ sandboxPkgPaths ++ maybeToList mNixLibDir) let dflags' = applyGopts . applyXopts $ dflags { -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,6,0) + backend = interpreterBackend, +#elif MIN_VERSION_ghc(9,2,0) backend = Interpreter, #else hscTarget = HscInterpreted , @@ -165,13 +178,32 @@ initScriptSession ghcPkgPaths = do --liftIO $ traceShowM (showSDoc dflags' (ppr packages)) _ <- setSessionDynFlags dflags' let safeImportDecl :: String -> Maybe String -> ImportDecl (GhcPass 'Parsed) - safeImportDecl fullModuleName mQualifiedName = ImportDecl { + safeImportDecl fullModuleName _mQualifiedName = ImportDecl { +#if MIN_VERSION_ghc(9,6,0) +#else ideclSourceSrc = NoSourceText, - -#if MIN_VERSION_ghc(9,2,0) +#endif +#if MIN_VERSION_ghc(9,6,0) + ideclImportList = Nothing, +#endif +#if MIN_VERSION_ghc(9,10,0) + ideclExt = XImportDeclPass + { ideclAnn = noAnn + , ideclSourceText = NoSourceText + , ideclImplicit = False + }, +#elif MIN_VERSION_ghc(9,6,0) + ideclExt = XImportDeclPass + { ideclAnn = EpAnnNotUsed + , ideclSourceText = NoSourceText + , ideclImplicit = False + }, +#elif MIN_VERSION_ghc(9,2,0) ideclExt = noAnn, + ideclImplicit = False, #else ideclExt = noExtField, + ideclImplicit = False, #endif #if MIN_VERSION_ghc(9,2,0) --GenLocated SrcSpanAnnA ModuleName @@ -189,16 +221,21 @@ initScriptSession ghcPkgPaths = do #else ideclSource = False, #endif - - ideclSafe = True, - ideclImplicit = False, - ideclQualified = if isJust mQualifiedName then QualifiedPre else NotQualified, -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,4,0) + ideclQualified = if isJust _mQualifiedName then QualifiedPre else NotQualified, +#endif +#if MIN_VERSION_ghc(9,6,0) + ideclAs = Nothing, +#elif MIN_VERSION_ghc(9,2,0) ideclAs = Just (noLocA (mkModuleName fullModuleName)), #else - ideclAs = noLoc . mkModuleName <$> mQualifiedName, + ideclAs = noLoc . mkModuleName <$> _mQualifiedName, +#endif +#if MIN_VERSION_ghc(9,6,0) +#else + ideclHiding = Nothing, #endif - ideclHiding = Nothing + ideclSafe = True } unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl modn Nothing) [ "Prelude", @@ -239,9 +276,14 @@ mkTypeForName :: String -> Ghc Type mkTypeForName name = do lBodyName <- parseName name case lBodyName of +#if MIN_VERSION_ghc(9,6,0) + _ :| (_:_) -> error "too many name matches" + bodyName :| _ -> do +#else [] -> error ("failed to parse " ++ name) _:_:_ -> error "too many name matches" [bodyName] -> do +#endif mThing <- lookupName bodyName case mThing of Nothing -> error ("failed to find " ++ name) diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index 233ac8cf..8bcac646 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -12,11 +12,16 @@ import ProjectM36.NormalizeExpr import qualified ProjectM36.Attribute as A import qualified ProjectM36.AttributeNames as AS import ProjectM36.TupleSet +#if MIN_VERSION_ghc(9,6,0) +import Control.Monad (foldM) +#endif import Control.Monad.State import Control.Monad.Reader import Control.Monad.Except import Control.Monad.Trans.Except import Data.Functor.Identity +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import qualified Data.Set as S import Data.Functor.Foldable as Fold @@ -533,12 +538,14 @@ applyStaticRestrictionCollapse expr = Extend n sub -> Extend n (applyStaticRestrictionCollapse sub) Restrict firstPred _ -> - let restrictions = sequentialRestrictions expr - finalExpr = last restrictions + let (finalExpr, restrictions) = case sequentialRestrictions expr of + [] -> (undefined, []) + x : xs -> (NE.last $ x :| xs, xs) + optFinalExpr = case finalExpr of Restrict _ subexpr -> applyStaticRestrictionCollapse subexpr otherExpr -> otherExpr - andPreds = foldr folder firstPred (tail restrictions) + andPreds = foldr folder firstPred restrictions folder (Restrict subpred _) acc = AndPredicate acc subpred folder _ _ = error "unexpected restriction expression in optimization phase" in diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs index 65eea868..a9770881 100644 --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -16,8 +16,14 @@ import ProjectM36.HashSecurely import ProjectM36.ReferencedTransactionIds import Codec.Winery +#if MIN_VERSION_ghc(9,6,0) +import Control.Monad (foldM, forM, unless, when) +import Control.Monad.Except +import Control.Monad.Reader +#else import Control.Monad.Except hiding (join) import Control.Monad.Reader hiding (join) +#endif import qualified Data.Vector as V import qualified Data.UUID as U import qualified Data.Set as S @@ -39,15 +45,15 @@ data TransactionIdLookup = TransactionIdLookup TransactionId | TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack] deriving (Show, Eq, Generic) deriving Serialise via WineryVariant TransactionIdLookup - + -- | Used for git-style head backtracking such as topic~3^2. data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~v: walk back n parents, arbitrarily choosing a parent when a choice must be made - TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent + TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent TransactionStampHeadBacktrack UTCTime -- ^ git equivalent of 'git-rev-list -n 1 --before X' find the first transaction which was created before the timestamp deriving (Show, Eq, Generic) deriving Serialise via WineryVariant TransactionIdHeadBacktrack - + -- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon. data TransactionGraphOperator = JumpToHead HeadName | JumpToTransaction TransactionId | @@ -59,11 +65,11 @@ data TransactionGraphOperator = JumpToHead HeadName | Rollback deriving (Eq, Show, Generic) deriving Serialise via WineryVariant TransactionGraphOperator - -isCommit :: TransactionGraphOperator -> Bool + +isCommit :: TransactionGraphOperator -> Bool isCommit Commit = True isCommit _ = False - + data ROTransactionGraphOperator = ShowGraph | ValidateMerkleHashes deriving Show @@ -94,12 +100,10 @@ headList :: TransactionGraph -> [(HeadName, TransactionId)] headList graph = map (second transactionId) (M.assocs (transactionHeadsForGraph graph)) headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName -headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then - Nothing - else - Just $ (head . M.keys) matchingTrans - where - matchingTrans = M.filter (transaction ==) heads +headNameForTransaction transaction (TransactionGraph heads _) = + case M.keys $ M.filter (transaction ==) heads of + [] -> Nothing + name : _ -> Just name transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction) transactionsForIds idSet graph = @@ -148,7 +152,7 @@ addTransactionToGraph headName newTrans graph = do when (S.size parentIds' < 1) (Left $ NewTransactionMissingParentError newId) --if the headName already exists, ensure that it refers to a parent case transactionForHead headName graph of - Nothing -> pure () -- any headName is OK + Nothing -> pure () -- any headName is OK Just trans -> when (S.notMember (transactionId trans) parentIds') (Left (HeadNameSwitchingHeadProhibitedError headName)) --validate that the transaction has no children unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId) @@ -171,10 +175,10 @@ newTransUncommittedReplace trans@(Transaction tid tinfo (Schemas ctx sschemas)) where uncommittedReplace UncommittedContextMarker = TransactionMarker tid uncommittedReplace marker = marker - relvars = relationVariables (concreteDatabaseContext trans) + relvars = relationVariables (concreteDatabaseContext trans) fixedRelvars = M.map (fmap uncommittedReplace) relvars fixedContext = ctx { relationVariables = fixedRelvars } - + validateGraph :: TransactionGraph -> Maybe [RelationalError] @@ -240,16 +244,16 @@ evalGraphOp _ _ _ graph (JumpToHead headName) = Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) False in Right (disconnectedTrans, graph) Nothing -> Left $ NoSuchHeadNameError headName - + evalGraphOp _ _ discon graph (WalkBackToTime backTime) = do let startTransId = Discon.parentId discon - jumpDest <- backtrackGraph graph startTransId (TransactionStampHeadBacktrack backTime) + jumpDest <- backtrackGraph graph startTransId (TransactionStampHeadBacktrack backTime) case transactionForId jumpDest graph of Left err -> Left err Right trans -> do let disconnectedTrans = Discon.freshTransaction (transactionId trans) (schemas trans) Right (disconnectedTrans, graph) - + -- add new head pointing to branchPoint -- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context) -- affects transactiongraph and the disconnectedtransaction is recreated based off the branch @@ -270,7 +274,7 @@ evalGraphOp stamp' newId (DisconnectedTransaction parentId schemas' _) graph (Br case addBranch stamp' newId newBranchName parentId graph of Left err -> Left err Right (_, newGraph) -> Right (newDiscon, newGraph) - + -- add the disconnected transaction to the graph -- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction evalGraphOp stamp' newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of @@ -290,8 +294,8 @@ evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case tra Right parentTransaction -> Right (newDiscon, graph) where newDiscon = Discon.freshTransaction parentId (schemas parentTransaction) - -evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = + +evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = runGraphRefRelationalExprM env $ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) where env = freshGraphRefRelationalExprEnv Nothing graph @@ -325,8 +329,8 @@ graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _ ] transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation -transactionParentsRelation trans graph = - if isRootTransaction trans then +transactionParentsRelation trans graph = + if isRootTransaction trans then mkRelation attrs emptyTupleSet else do parentTransSet <- parentTransactions trans graph @@ -355,7 +359,7 @@ createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) transactionId trans2], stamp = stamp', merkleHash = mempty }) (schemas selectedTrans) - + -- merge functions, relvars, individually createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 = createUnionMergeTransaction stamp' newId strat t2 @@ -369,11 +373,11 @@ validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) - validateHeadName headName graph (t1, t2) = case transactionForHead headName graph of Nothing -> throwError (MergeTransactionError SelectedHeadMismatchMergeError) - Just trans -> if trans /= t1 && trans /= t2 then + Just trans -> if trans /= t1 && trans /= t2 then throwError (MergeTransactionError SelectedHeadMismatchMergeError) else pure trans - + -- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal. The subgraph must also include any transactions which are referenced by other transactions. subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do @@ -390,8 +394,10 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans trav errors = lefts childSearches pathsFound = rights childSearches realErrors = filter (/= FailedToFindTransactionError goalid) errors - -- report any non-search-related errors - unless (null realErrors) (Left (head realErrors)) + -- report any non-search-related errors + case realErrors of + [] -> pure () + err : _ -> Left err -- if no paths found, search the parent if null pathsFound then case oneParent currentTrans' of @@ -409,7 +415,7 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans trav Right (TransactionGraph resultHeads closedTransactionSet) where oneParent (Transaction _ tinfo _) = transactionForId (NE.head (parents tinfo)) origGraph - + -- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError. pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction) pathToTransaction graph currentTransaction targetTransaction accumTransSet = do @@ -424,12 +430,14 @@ pathToTransaction graph currentTransaction targetTransaction accumTransSet = do let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) (S.toList currentTransChildren) let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches) paths = rights searches - if not (null realErrors) then -- found some real errors - Left (head realErrors) - else if null paths then -- failed to find transaction in all children - Left (FailedToFindTransactionError targetId) - else --we have some paths! - Right (S.unions paths) + case realErrors of + -- found some real errors + err : _ -> Left err + [] -> case paths of + -- failed to find transaction in all children + [] -> Left $ FailedToFindTransactionError targetId + -- we have some paths! + _ -> Right $ S.unions paths mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> GraphRefRelationalExprM (DisconnectedTransaction, TransactionGraph) mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = do @@ -462,8 +470,8 @@ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = d let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph) newDiscon = Discon.freshTransaction newId (schemas newTrans) pure (newDiscon, newGraph') - ---TEMPORARY COPY/PASTE + +--TEMPORARY COPY/PASTE showTransactionStructureX :: Bool -> Transaction -> TransactionGraph -> String showTransactionStructureX showRelVars trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo ++ relVarsInfo where @@ -473,13 +481,13 @@ showTransactionStructureX showRelVars trans graph = headInfo ++ " " ++ show (tra parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of Left err -> show err Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet - + showGraphStructureX :: Bool -> TransactionGraph -> String showGraphStructureX showRelVars graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet where folder trans acc = acc ++ showTransactionStructureX showRelVars trans graph ++ "\n" headsInfo = show $ M.map transactionId heads - + -- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph. filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet @@ -487,7 +495,7 @@ filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet validIds = S.map transactionId (transactionsForGraph graph) newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph) newHeads = M.map (filterTransaction validIds) heads - + --helper function for commonalities in union merge createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction createUnionMergeTransaction stamp' newId strategy (t1,t2) = do @@ -496,16 +504,16 @@ createUnionMergeTransaction stamp' newId strategy (t1,t2) = do liftMergeE x = case x of Left e -> throwError (MergeTransactionError e) Right t -> pure t - + graph <- gfGraph - preference <- case strategy of + preference <- case strategy of UnionMergeStrategy -> pure PreferNeither UnionPreferMergeStrategy preferBranch -> case transactionForHead preferBranch graph of Nothing -> throwError (MergeTransactionError (PreferredHeadMissingMergeError preferBranch)) Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond badStrat -> throwError (MergeTransactionError (InvalidMergeStrategyError badStrat)) - + incDeps <- liftMergeE $ unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB) relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB) atomFuncs <- liftMergeE $ unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB) @@ -515,8 +523,8 @@ createUnionMergeTransaction stamp' newId strategy (t1,t2) = do registeredQs <- liftMergeE $ unionMergeRegisteredQueries preference (registeredQueries contextA) (registeredQueries contextB) -- TODO: add merge of subschemas let newContext = DatabaseContext { - inclusionDependencies = incDeps, - relationVariables = relVars, + inclusionDependencies = incDeps, + relationVariables = relVars, atomFunctions = atomFuncs, dbcFunctions = dbcFuncs, notifications = notifs, @@ -533,15 +541,15 @@ createUnionMergeTransaction stamp' newId strategy (t1,t2) = do lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph -lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of +lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of Nothing -> Left (NoSuchHeadNameError headName) Just headTrans -> do traversedId <- traverseGraph graph (transactionId headTrans) backtracks transactionForId traversedId graph - + traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId traverseGraph graph = foldM (backtrackGraph graph) - + backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId -- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do @@ -556,28 +564,26 @@ backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do pure (transactionId parentTrans) else backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1)) - + backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do trans <- transactionForId currentTid graph let parentIds' = parentIds trans if S.size parentIds' < 1 then - Left RootTransactionTraversalError + Left RootTransactionTraversalError else if S.size parentIds' < steps then Left (ParentCountTraversalError (S.size parentIds') steps) else pure (S.elemAt (steps - 1) parentIds') - -backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp') = do + +backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp') = do trans <- transactionForId currentTid graph - let parentIds' = parentIds trans + let parentIds' = parentIds trans if timestamp trans <= stamp' then pure currentTid - else if S.null parentIds' then - Left RootTransactionTraversalError - else - let arbitraryParent = head (S.toList parentIds') in - backtrackGraph graph arbitraryParent btrack - + else case S.toList parentIds' of + [] -> Left RootTransactionTraversalError + arbitraryParent : _ -> backtrackGraph graph arbitraryParent btrack + -- | Create a temporary branch for commit, merge the result to head, delete the temporary branch. This is useful to atomically commit a transaction, avoiding a TransactionIsNotHeadError but trading it for a potential MergeError. --this is not a GraphOp because it combines multiple graph operations autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph) @@ -585,23 +591,23 @@ autoMergeToHead stamp' (tempBranchTransId, tempCommitTransId, mergeTransId) disc let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId --create the temp branch (discon', graph') <- evalGraphOp stamp' tempBranchTransId discon graph (Branch tempBranchName) - + --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type (discon'', graph'') <- evalGraphOp stamp' tempCommitTransId discon' graph' Commit - + --jump to merge head (discon''', graph''') <- evalGraphOp stamp' tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName) - + --create the merge (discon'''', graph'''') <- evalGraphOp stamp' mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName) - + --delete the temp branch (discon''''', graph''''') <- evalGraphOp stamp' tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName) {- let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''') traceShowM rel -} - + pure (discon''''', graph''''') @@ -620,7 +626,7 @@ calculateMerkleHash trans graph = hashTransaction trans parentTranses Right t -> t validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError () -validateMerkleHash trans graph = +validateMerkleHash trans graph = when (expectedHash /= actualHash) $ Left (MerkleValidationError (transactionId trans) expectedHash actualHash) where @@ -634,7 +640,7 @@ validateMerkleHashes :: TransactionGraph -> Either [MerkleValidationError] () validateMerkleHashes graph = if null errs then pure () else Left errs where - errs = S.foldr validateTrans [] (transactionsForGraph graph) + errs = S.foldr validateTrans [] (transactionsForGraph graph) validateTrans trans acc = case validateMerkleHash trans graph of Left err -> err : acc diff --git a/src/lib/ProjectM36/TransactionGraph/Merge.hs b/src/lib/ProjectM36/TransactionGraph/Merge.hs index b15fc6c3..657bef0e 100644 --- a/src/lib/ProjectM36/TransactionGraph/Merge.hs +++ b/src/lib/ProjectM36/TransactionGraph/Merge.hs @@ -3,7 +3,12 @@ module ProjectM36.TransactionGraph.Merge where import ProjectM36.Base import ProjectM36.Error import ProjectM36.RelationalExpression +#if MIN_VERSION_ghc(9,6,0) +import Control.Monad (foldM) +import Control.Monad.Except +#else import Control.Monad.Except hiding (join) +#endif import qualified Data.Set as S import qualified Data.Map as M import qualified ProjectM36.TypeConstructorDef as TCD diff --git a/src/lib/ProjectM36/TransactionGraph/Persist.hs b/src/lib/ProjectM36/TransactionGraph/Persist.hs index 3e028c69..75f531a4 100644 --- a/src/lib/ProjectM36/TransactionGraph/Persist.hs +++ b/src/lib/ProjectM36/TransactionGraph/Persist.hs @@ -68,11 +68,9 @@ checkForOtherVersions :: FilePath -> IO (Either PersistenceError ()) checkForOtherVersions dbdir = do versionMatches <- globDir1 (compile "m36v*") dbdir let otherVersions = L.delete transactionLogFileName (map takeFileName versionMatches) - if not (null otherVersions) then - pure (Left (WrongDatabaseFormatVersionError transactionLogFileName (head otherVersions))) - else - pure (Right ()) - + pure $ case otherVersions of + [] -> Right () + x : _ -> Left $ WrongDatabaseFormatVersionError transactionLogFileName x setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (LockFile, LockFileHash)) setupDatabaseDir sync dbdir bootstrapGraph = do diff --git a/src/lib/ProjectM36/Tuple.hs b/src/lib/ProjectM36/Tuple.hs index 5c1b2d33..393a3160 100644 --- a/src/lib/ProjectM36/Tuple.hs +++ b/src/lib/ProjectM36/Tuple.hs @@ -107,22 +107,29 @@ singleTupleSetJoin tup1 tupSet = HS.union where mapper tup2 = singleTupleJoin tup1 tup2 -} - + -- if the keys share some keys and values, then merge the tuples -- if there are shared attributes, if they match, create a new tuple from the atoms of both tuples based on the attribute ordering argument singleTupleJoin :: Attributes -> RelationTuple -> RelationTuple -> Either RelationalError (Maybe RelationTuple) -singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = if - atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2 - then - return Nothing - else - return $ Just $ RelationTuple joinedAttrs newVec - where +singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = do + k1 <- atomsForAttributeNames keysIntersection tup1 + k2 <- atomsForAttributeNames keysIntersection tup2 + pure $ if k1 == k2 + then Just $ RelationTuple joinedAttrs newVec + else Nothing + where + keysIntersection :: V.Vector AttributeName keysIntersection = V.map attributeName attrsIntersection + attrsIntersection :: V.Vector Attribute attrsIntersection = V.filter (`V.elem` attributesVec tupAttrs1) (attributesVec tupAttrs2) - newVec = V.map (findAtomForAttributeName . attributeName) (attributesVec joinedAttrs) + newVec :: V.Vector Atom + newVec = V.mapMaybe (findAtomForAttributeName . attributeName) (attributesVec joinedAttrs) --search both tuples for the attribute - findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2] + findAtomForAttributeName :: AttributeName -> Maybe Atom + findAtomForAttributeName attrName = + case rights $ atomForAttributeName attrName <$> [tup1, tup2] of + [] -> Nothing + x : _ -> Just x --same consideration as Data.List.union- duplicates in v1 are not de-duped vectorUnion :: (Eq a) => V.Vector a -> V.Vector a -> V.Vector a diff --git a/src/lib/ProjectM36/TupleSet.hs b/src/lib/ProjectM36/TupleSet.hs index 100bb194..d5f5b4fd 100644 --- a/src/lib/ProjectM36/TupleSet.hs +++ b/src/lib/ProjectM36/TupleSet.hs @@ -21,10 +21,9 @@ verifyTupleSet attrs tupleSet = do let tupleList = map (verifyTuple attrs) (asList tupleSet) `P.using` P.parListChunk chunkSize P.r0 chunkSize = (length . asList) tupleSet `div` 24 --let tupleList = P.parMap P.rdeepseq (verifyTuple attrs) (HS.toList tupleSet) - if not (null (lefts tupleList)) then - Left $ head (lefts tupleList) - else - return $ RelationTupleSet $ (HS.toList . HS.fromList) (rights tupleList) + case lefts tupleList of + x : _ -> Left x + _ -> pure $ RelationTupleSet $ (HS.toList . HS.fromList) (rights tupleList) mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTupleSet mkTupleSet attrs tuples = verifyTupleSet attrs (RelationTupleSet tuples) From c3fc5c706a683aba0136949d576d435354ca54e6 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 21 Aug 2024 12:36:58 -0400 Subject: [PATCH 158/170] replace scotty deprecated raise with scotty throw for 500 errors replace deprecated scotty param function resolves #372 --- examples/Plantfarm.hs | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/examples/Plantfarm.hs b/examples/Plantfarm.hs index e4e23943..8789d1bb 100644 --- a/examples/Plantfarm.hs +++ b/examples/Plantfarm.hs @@ -6,15 +6,14 @@ {-# LANGUAGE DerivingVia #-} - +import Control.Monad.Catch (Exception) import Codec.Winery (Serialise, WineryVariant(WineryVariant)) import Control.DeepSeq (NFData) import Data.Aeson (FromJSON, ToJSON(toEncoding, toJSON)) import Data.Data (Proxy(Proxy)) import Data.Either (lefts, rights) import Data.Functor (($>)) -import Data.Text as T (Text) -import qualified Data.Text.Lazy as TL (pack) +import Data.Text as T (Text,pack) import GHC.Generics (Generic) import qualified ProjectM36.Base as Base import ProjectM36.DatabaseContext @@ -147,7 +146,7 @@ main = do -- retrieve a plant by name S.get "/plant/:name" $ do - n <- S.param "name" + n <- S.pathParam "name" e <- liftIO $ getPlant c n p <- handleWebError e S.json p @@ -170,7 +169,7 @@ main = do -- watering the plant having the provided name. -- This will water the plant and might let it progress to the next stage. It might also die. S.post "/plant/water/:name" $ do - n <- S.param "name" + n <- S.pathParam "name" e <- liftIO $ waterPlant c n p <- handleWebError e S.json p @@ -190,14 +189,14 @@ main = do -- deleting all plants at a specific stage S.delete "/plants?stage=:stage" $ do - s <- S.param "stage" + s <- S.pathParam "stage" e <- liftIO $ deletePlantsByStage c s p <- handleWebError e S.json p -- deleting all plants at a specific stage S.delete "/plants" $ do - s <- S.param "name" + s <- S.queryParam "name" e <- liftIO $ deletePlantByName c s p <- handleWebError e S.json p @@ -208,15 +207,20 @@ main = do ps <- handleWebErrors e S.json ps +data WebError = WebError T.Text + deriving Show + +instance Exception WebError + handleWebError :: Either Err b -> S.ActionM b -handleWebError (Left e) = S.raise (TL.pack $ "An error occurred:\n" <> show e) +handleWebError (Left e) = S.throw (WebError (T.pack $ "An error occurred:\n" <> show e)) handleWebError (Right v) = pure v handleWebErrors :: [Either Err b] -> S.ActionM [b] handleWebErrors e = do case lefts e of [] -> pure (rights e) - l -> S.raise (TL.pack $ "Errors occurred:\n" <> concatMap ((<>"\n") . show) l) + l -> S.throw (WebError (T.pack $ "Errors occurred:\n" <> concatMap ((<>"\n") . show) l)) -- | watering a plant and thereby possibly updating its stage From 861ab524038dfc59cff1de6a318459032bcfbb39 Mon Sep 17 00:00:00 2001 From: AgentM Date: Wed, 21 Aug 2024 14:07:25 -0400 Subject: [PATCH 159/170] add exceptions dependency to PlantFarm example --- project-m36.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project-m36.cabal b/project-m36.cabal index 993bb1e0..2b98abc0 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -586,7 +586,7 @@ Executable Example-Hair Executable Example-Plantfarm Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: aeson, barbies, base, containers, deepseq, hashable, project-m36, random, scotty >= 0.22, text, winery + Build-Depends: aeson, barbies, base, containers, deepseq, hashable, project-m36, random, scotty >= 0.22, text, winery, exceptions Main-Is: examples/Plantfarm.hs GHC-Options: -Wall -threaded From 87e4b7587818540c3d802ec22cca39a60d2b5d7e Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 07:35:55 -0400 Subject: [PATCH 160/170] disable GHC 9.6 in stack- I couldn't find a way to enable head.hackage in stack remove special casing for curryer-rpc after releasing curryer 0.3.7 --- .github/workflows/ci.yaml | 6 +++--- cabal.project | 4 +++- project-m36.cabal | 2 +- stack.ghc9.2.yaml | 2 +- stack.ghc9.4.yaml | 2 +- 5 files changed, 9 insertions(+), 7 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 3b28ab9a..316d6a70 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -37,9 +37,9 @@ jobs: ghc_version: - 9.2 - 9.4 - - 9.6 - - 9.8 - - 9.10 +# - 9.6 +# - 9.8 +# - 9.10 include: - os: macos-latest ghc_version: 9.2 diff --git a/cabal.project b/cabal.project index d6ed5aeb..b3056d4b 100644 --- a/cabal.project +++ b/cabal.project @@ -4,6 +4,9 @@ packages: package * split-sections: True +if impl(ghc >= 9.2) + allow-newer: fast-builder:base + -- Required patch from head.hackage to fix: -- * `winery` compilation with GHC-9.6 -- * `barbies-th` compilation with GHC-9.8 @@ -33,7 +36,6 @@ if impl(ghc >= 9.6) if impl(ghc >= 9.8) allow-newer: - curryer-rpc:base, streamly-bytestring:bytestring, if impl(ghc >= 9.10) diff --git a/project-m36.cabal b/project-m36.cabal index 50f66c86..2b349dd1 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -88,7 +88,7 @@ Library cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, - curryer-rpc>=0.3.6, + curryer-rpc>=0.3.7, network, async, vector-instances, diff --git a/stack.ghc9.2.yaml b/stack.ghc9.2.yaml index f40f7b57..f789fefb 100644 --- a/stack.ghc9.2.yaml +++ b/stack.ghc9.2.yaml @@ -6,7 +6,7 @@ extra-deps: - streamly-0.10.1 - streamly-core-0.2.2 - streamly-bytestring-0.2.2 - - curryer-rpc-0.3.6 + - curryer-rpc-0.3.7 - fast-builder-0.1.2.1 - rset-1.0.0 - winery-1.4 diff --git a/stack.ghc9.4.yaml b/stack.ghc9.4.yaml index 18426519..a8583cf2 100644 --- a/stack.ghc9.4.yaml +++ b/stack.ghc9.4.yaml @@ -6,7 +6,7 @@ extra-deps: - streamly-0.10.1 - streamly-core-0.2.2 - streamly-bytestring-0.2.2 - - curryer-rpc-0.3.6 + - curryer-rpc-0.3.7 - fast-builder-0.1.2.1 - rset-1.0.0 - winery-1.4 From 34e7228664659f9440066d18822c09a176300e3d Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 15:09:12 -0400 Subject: [PATCH 161/170] disable cabal check due to failure --- .github/workflows/haskell-ci.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 77a04e34..9a24cabd 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -193,10 +193,10 @@ jobs: - name: tests run: | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct - - name: cabal check - run: | - cd ${PKGDIR_project_m36} || false - ${CABAL} -vnormal check +# - name: cabal check +# run: | +# cd ${PKGDIR_project_m36} || false +# ${CABAL} -vnormal check - name: haddock run: | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all From bdbe9f96ac9ec93adaeb631b0e61b6c2bd3b1cee Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 15:09:32 -0400 Subject: [PATCH 162/170] move Changelog and README to extra-doc-files in config --- project-m36.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/project-m36.cabal b/project-m36.cabal index 2b349dd1..ddfd4682 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -12,7 +12,8 @@ Category: Relational Algebra Maintainer: agentm@themactionfaction.com Synopsis: Relational Algebra Engine Description: A relational algebra engine which can be used to persist and query Haskell data types. -Extra-Source-Files: Changelog.markdown README.markdown scripts/DateExamples.tutd scripts/multiline.tutd +Extra-Source-Files: scripts/DateExamples.tutd scripts/multiline.tutd +Extra-Doc-Files: Changelog.markdown README.markdown tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 Source-Repository head From a8996f01447421327f83b867e5cab96d24395059 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 15:09:46 -0400 Subject: [PATCH 163/170] fix GHC 9.2 support in ScriptSession --- src/lib/ProjectM36/ScriptSession.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/lib/ProjectM36/ScriptSession.hs b/src/lib/ProjectM36/ScriptSession.hs index 2834ed90..5b15b987 100644 --- a/src/lib/ProjectM36/ScriptSession.hs +++ b/src/lib/ProjectM36/ScriptSession.hs @@ -221,9 +221,7 @@ initScriptSession ghcPkgPaths = do #else ideclSource = False, #endif -#if MIN_VERSION_ghc(9,4,0) ideclQualified = if isJust _mQualifiedName then QualifiedPre else NotQualified, -#endif #if MIN_VERSION_ghc(9,6,0) ideclAs = Nothing, #elif MIN_VERSION_ghc(9,2,0) From 1b95b5db4fb8f664403bf4f5bcb73e4f8922b48f Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 15:57:35 -0400 Subject: [PATCH 164/170] reorder and remove some haskell-ci steps to allow for custom cabal.project instead of ci-generated cabal.project --- .github/workflows/haskell-ci.yml | 35 ++------------------------------ 1 file changed, 2 insertions(+), 33 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 9a24cabd..98ba80c1 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -125,9 +125,6 @@ jobs: $HC --version || true $HC --print-project-git-commit-id || true $CABAL --version || true - - name: update cabal index - run: | - $CABAL v2-update -v - name: install cabal-plan run: | mkdir -p $HOME/.cabal/bin @@ -139,37 +136,9 @@ jobs: cabal-plan --version - name: checkout uses: actions/checkout@v4 - with: - path: source - - name: initial cabal.project for sdist - run: | - touch cabal.project - echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project - cat cabal.project - - name: sdist - run: | - mkdir -p sdist - $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist - - name: unpack - run: | - mkdir -p unpacked - find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; - - name: generate cabal.project + - name: update cabal index run: | - PKGDIR_project_m36="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/project-m36-[0-9.]*')" - echo "PKGDIR_project_m36=${PKGDIR_project_m36}" >> "$GITHUB_ENV" - rm -f cabal.project cabal.project.local - touch cabal.project - touch cabal.project.local - echo "packages: ${PKGDIR_project_m36}" >> cabal.project - echo "package project-m36" >> cabal.project - echo " ghc-options: -Werror=missing-methods" >> cabal.project - echo "allow-newer: fast-builder:base" >> cabal.project - cat >> cabal.project <> cabal.project.local - cat cabal.project - cat cabal.project.local + $CABAL v2-update -v - name: dump install plan run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all From 80e005fcdc5eb9a447e1a8de29b14352edae8ef9 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 16:02:48 -0400 Subject: [PATCH 165/170] add compiler arg to cabal update in ci --- .github/workflows/haskell-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 98ba80c1..d50bc60e 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -138,7 +138,7 @@ jobs: uses: actions/checkout@v4 - name: update cabal index run: | - $CABAL v2-update -v + $CABAL v2-update -v -w $ARG_COMPILER - name: dump install plan run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all From 9f875339db6ad9541c25860003a1b9e9363d6958 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 16:58:21 -0400 Subject: [PATCH 166/170] fix import in test-static-optimizer --- test/Relation/StaticOptimizer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Relation/StaticOptimizer.hs b/test/Relation/StaticOptimizer.hs index 2de7aada..5b6a4406 100644 --- a/test/Relation/StaticOptimizer.hs +++ b/test/Relation/StaticOptimizer.hs @@ -6,9 +6,9 @@ import ProjectM36.TupleSet import ProjectM36.StaticOptimizer import ProjectM36.DatabaseContext as DBC import System.Exit -import Control.Monad.State import Test.HUnit import qualified Data.Set as S +import Control.Monad (forM_) main :: IO () main = do From 65a7d4e2f25a6342a45d8030ffe2fdd33dc7207c Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 17:44:29 -0400 Subject: [PATCH 167/170] update docker build to use curryer-rpc 0.3.7 --- release.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/release.nix b/release.nix index 2acff7da..a3b62663 100644 --- a/release.nix +++ b/release.nix @@ -15,8 +15,8 @@ let overrides = self: super: { curryer-rpc = self.callHackageDirect { pkg = "curryer-rpc"; - ver = "0.3.6"; - sha256 = "sha256-GgYxb3eBhANGMdN3FlMgD9vZUqoDsz89OFIBxwK4YtY="; } {}; + ver = "0.3.7"; + sha256 = "sha256-zRp356hxlQtpm2n2lohZxT+O+h6ebmNoxaJeY/Go/cU="; } {}; streamly = self.callHackageDirect { pkg = "streamly"; From 3481782b7f69b2afa9cbc88bf15239bd70755102 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 21:48:30 -0400 Subject: [PATCH 168/170] replace MIN_VERSION_ghc with MIN_VERSION_base for reasons unclear, the nix build does not include a MIN_VERSION_ghc macro --- .../Interpreter/RODatabaseContextOperator.hs | 5 ----- src/lib/ProjectM36/AtomType.hs | 4 ---- src/lib/ProjectM36/AttributeNames.hs | 1 + src/lib/ProjectM36/Client/Simple.hs | 4 ++-- src/lib/ProjectM36/RelationalExpression.hs | 15 ++++++--------- src/lib/ProjectM36/StaticOptimizer.hs | 2 +- src/lib/ProjectM36/TransactionGraph.hs | 7 ++----- src/lib/ProjectM36/TransactionGraph/Merge.hs | 3 ++- 8 files changed, 14 insertions(+), 27 deletions(-) diff --git a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs index abcae1c9..2b4f0db0 100644 --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} module TutorialD.Interpreter.RODatabaseContextOperator where import ProjectM36.Base @@ -13,11 +12,7 @@ import TutorialD.Interpreter.Base import TutorialD.Interpreter.RelationalExpr import TutorialD.Interpreter.DatabaseContextExpr import TutorialD.Printer -#if MIN_VERSION_base(4,18,0) import Control.Monad (when) -#else -import Control.Monad.State -#endif import qualified Data.Text as T import ProjectM36.Relation.Show.Gnuplot import ProjectM36.HashSecurely diff --git a/src/lib/ProjectM36/AtomType.hs b/src/lib/ProjectM36/AtomType.hs index 0d68fd89..e148514e 100644 --- a/src/lib/ProjectM36/AtomType.hs +++ b/src/lib/ProjectM36/AtomType.hs @@ -13,11 +13,7 @@ import qualified Data.Set as S import qualified Data.List as L import Data.Maybe (isJust) import Data.Either (rights, lefts) -#if MIN_VERSION_ghc(9,6,0) import Control.Monad (foldM, unless, when) -#else -import Control.Monad.Writer -#endif import qualified Data.Map as M import qualified Data.Text as T diff --git a/src/lib/ProjectM36/AttributeNames.hs b/src/lib/ProjectM36/AttributeNames.hs index 58b25c63..e6c79dd7 100644 --- a/src/lib/ProjectM36/AttributeNames.hs +++ b/src/lib/ProjectM36/AttributeNames.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module ProjectM36.AttributeNames where import ProjectM36.Base import qualified Data.Set as S diff --git a/src/lib/ProjectM36/Client/Simple.hs b/src/lib/ProjectM36/Client/Simple.hs index def7d575..3b59d9a7 100644 --- a/src/lib/ProjectM36/Client/Simple.hs +++ b/src/lib/ProjectM36/Client/Simple.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-} -- | A simplified client interface for Project:M36 database access. module ProjectM36.Client.Simple ( simpleConnectProjectM36, @@ -31,7 +31,7 @@ module ProjectM36.Client.Simple ( ) where import Control.Exception.Base -#if MIN_VERSION_ghc(9,6,0) +#if MIN_VERSION_base(4,18,0) import Control.Monad ((<=<)) #endif import Control.Monad.Reader diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs index 1984789d..4d02910e 100644 --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -22,16 +22,13 @@ import qualified ProjectM36.Attribute as A import qualified Data.Map as M import qualified Data.HashSet as HS import qualified Data.Set as S -#if MIN_VERSION_ghc(9,6,0) import Control.Monad (foldM, unless, when) -import Control.Monad.State -import Control.Monad.Except -import Control.Monad.Reader as R -#else -import Control.Monad.State hiding (join) -import Control.Monad.Except hiding (join) -import Control.Monad.Reader as R hiding (join) -#endif +import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError, catchError) +import Control.Monad.Reader (ReaderT, runReaderT, asks, ask, local) +import qualified Control.Monad.Reader as R +import Control.Monad.State (gets, get, put) +import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (liftIO) import Data.Bifunctor (second) import Data.Maybe import Data.Tuple (swap) diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs index 8bcac646..ceecde5a 100644 --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -12,7 +12,7 @@ import ProjectM36.NormalizeExpr import qualified ProjectM36.Attribute as A import qualified ProjectM36.AttributeNames as AS import ProjectM36.TupleSet -#if MIN_VERSION_ghc(9,6,0) +#if MIN_VERSION_base(4,18,0) import Control.Monad (foldM) #endif import Control.Monad.State diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs index a9770881..9b9948b8 100644 --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -16,14 +16,11 @@ import ProjectM36.HashSecurely import ProjectM36.ReferencedTransactionIds import Codec.Winery -#if MIN_VERSION_ghc(9,6,0) +#if MIN_VERSION_base(4,18,0) import Control.Monad (foldM, forM, unless, when) +#endif import Control.Monad.Except import Control.Monad.Reader -#else -import Control.Monad.Except hiding (join) -import Control.Monad.Reader hiding (join) -#endif import qualified Data.Vector as V import qualified Data.UUID as U import qualified Data.Set as S diff --git a/src/lib/ProjectM36/TransactionGraph/Merge.hs b/src/lib/ProjectM36/TransactionGraph/Merge.hs index 657bef0e..f314a8ec 100644 --- a/src/lib/ProjectM36/TransactionGraph/Merge.hs +++ b/src/lib/ProjectM36/TransactionGraph/Merge.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE CPP #-} --Transaction Merge Engines module ProjectM36.TransactionGraph.Merge where import ProjectM36.Base import ProjectM36.Error import ProjectM36.RelationalExpression -#if MIN_VERSION_ghc(9,6,0) +#if MIN_VERSION_base(4,18,0) import Control.Monad (foldM) import Control.Monad.Except #else From 3dedc28ad96ed2842ac8c0b82d525a323dd16105 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 22:02:38 -0400 Subject: [PATCH 169/170] update documentation for latest supported GHC --- README.markdown | 2 +- docs/introduction_to_projectm36.markdown | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/README.markdown b/README.markdown index fba1c62d..347f1086 100644 --- a/README.markdown +++ b/README.markdown @@ -107,7 +107,7 @@ Project:M36 supports multiple frontends which target different audiences. ## Development -Project:M36 is developed in Haskell and compiled with GHC 8.8 or later. +Project:M36 is developed in Haskell and compiled with GHC 9.2 or later. ## Related Projects diff --git a/docs/introduction_to_projectm36.markdown b/docs/introduction_to_projectm36.markdown index d299e436..c510bcb0 100644 --- a/docs/introduction_to_projectm36.markdown +++ b/docs/introduction_to_projectm36.markdown @@ -51,7 +51,7 @@ Requirements: To build with stack: -* [GHC 8.10.7 or greater](https://www.haskell.org/downloads) +* [GHC 9.2 or greater](https://www.haskell.org/downloads) * [Haskell stack](https://docs.haskellstack.org/en/stable/README/) * Linux, macOS, or Microsoft Windows @@ -63,7 +63,7 @@ Compilation steps: At this point, the TutorialD interactive interpreter can be run using ```stack exec tutd```. -Alternative building with GHC 8.6.5 or greater: +Alternative building with GHC 9.2 or greater: * ```cabal new-build``` From d39483eaeb615ddebc92453d9da2747765164145 Mon Sep 17 00:00:00 2001 From: AgentM Date: Sun, 25 Aug 2024 22:41:10 -0400 Subject: [PATCH 170/170] update Changelog --- Changelog.markdown | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Changelog.markdown b/Changelog.markdown index ed5fc5b4..d3afee3a 100644 --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,4 +1,4 @@ -# 2024-87-12 (v1.1.0) +# 2024-08-25 (v1.1.0) * add support for GHC 9.6, GHC 9.8, and GHC 9.10 * clean up compiler warnings

" <> prettyAttribute attr <> ordering (attributeName attr) <> "" <> prettyAttribute attr <> ordering (A.attributeName attr) <> "