diff --git a/Changelog.markdown b/Changelog.markdown --- 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/project-m36.cabal b/project-m36.cabal --- 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/bin/TutorialD/Interpreter/Base.hs b/src/bin/TutorialD/Interpreter/Base.hs --- a/src/bin/TutorialD/Interpreter/Base.hs +++ b/src/bin/TutorialD/Interpreter/Base.hs @@ -69,10 +69,12 @@ istart <- letterChar <|> char '_' identifierRemainder istart +identifierP :: Parser Text +identifierP = identifier <* spaceConsumer + 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/DatabaseContextExpr.hs b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs --- a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs @@ -98,7 +98,7 @@ 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 @@ 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 @@ funcDepP :: Parser DatabaseContextExpr funcDepP = do reserved "funcdep" - keyName <- identifier + keyName <- identifierP source <- parens attributeListP reserved "->" dependents <- parens attributeListP @@ -141,7 +141,7 @@ attributeAssignmentP :: Parser (AttributeName, AtomExpr) attributeAssignmentP = do - attrName <- identifier + attrName <- identifierP reservedOp ":=" atomExpr <- atomExprP pure (attrName, atomExpr) @@ -149,7 +149,7 @@ addNotificationP :: Parser DatabaseContextExpr addNotificationP = do reserved "notify" - notName <- identifier + notName <- identifierP triggerExpr <- relExprP resultOldExpr <- relExprP AddNotification notName triggerExpr resultOldExpr <$> relExprP @@ -157,7 +157,7 @@ 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 --- a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs @@ -15,7 +15,7 @@ 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 --- a/src/bin/TutorialD/Interpreter/Import/BasicExamples.hs +++ b/src/bin/TutorialD/Interpreter/Import/BasicExamples.hs @@ -20,7 +20,7 @@ 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 --- a/src/bin/TutorialD/Interpreter/Import/CSV.hs +++ b/src/bin/TutorialD/Interpreter/Import/CSV.hs @@ -25,6 +25,6 @@ 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 --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -73,7 +73,7 @@ showConstraintsP :: Parser RODatabaseContextOperator showConstraintsP = do colonOp ":constraints" - ShowConstraints <$> option "" identifier + ShowConstraints <$> option "" identifierP plotRelExprP :: Parser RODatabaseContextOperator plotRelExprP = do @@ -227,7 +227,7 @@ 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 --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -15,6 +15,7 @@ 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 = 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 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 attributeAtomExprP :: Parser (AtomExprBase a) attributeAtomExprP = do @@ -247,6 +250,26 @@ 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) + +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 = FunctionAtomExpr <$> functionNameP <*> parens (sepBy atomExprP comma) <*> parseMarkerP @@ -291,7 +314,7 @@ createMacroP :: RelationalMarkerExpr a => Parser (WithNameExprBase a, RelationalExprBase a) createMacroP = do - name <- identifier + name <- identifierP reservedOp "as" expr <- relExprP marker <- parseMarkerP diff --git a/src/bin/TutorialD/Interpreter/SchemaOperator.hs b/src/bin/TutorialD/Interpreter/SchemaOperator.hs --- a/src/bin/TutorialD/Interpreter/SchemaOperator.hs +++ b/src/bin/TutorialD/Interpreter/SchemaOperator.hs @@ -19,7 +19,7 @@ setCurrentSchemaP :: Parser SchemaOperator setCurrentSchemaP = do reserved ":setschema" - SetCurrentSchema <$> identifier + SetCurrentSchema <$> identifierP schemaExprP :: Parser SchemaExpr schemaExprP = addSubschemaP <|> @@ -28,7 +28,7 @@ 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 --- a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs @@ -20,7 +20,7 @@ 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 --- a/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs @@ -17,12 +17,12 @@ 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 @@ 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 = (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 --- a/src/bin/TutorialD/Interpreter/Types.hs +++ b/src/bin/TutorialD/Interpreter/Types.hs @@ -13,20 +13,25 @@ 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 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 typeConstructorDefP :: Parser TypeConstructorDef @@ -58,10 +63,10 @@ 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 @@ -75,4 +80,4 @@ relVarNameP :: Parser RelVarName -relVarNameP = try uncapitalizedIdentifier <|> quotedIdentifier +relVarNameP = uncapitalizedOrQuotedIdentifier <* spaceConsumer diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -40,10 +40,12 @@ 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 (RelationAtomExpr relExpr) = pretty relExpr @@ -154,6 +156,7 @@ 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/Arbitrary.hs b/src/lib/ProjectM36/Arbitrary.hs --- 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,11 +29,20 @@ 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 --- a/src/lib/ProjectM36/Atom.hs +++ b/src/lib/ProjectM36/Atom.hs @@ -23,7 +23,7 @@ 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/AtomFunction.hs b/src/lib/ProjectM36/AtomFunction.hs --- a/src/lib/ProjectM36/AtomFunction.hs +++ b/src/lib/ProjectM36/AtomFunction.hs @@ -13,7 +13,9 @@ 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/AtomFunctionError.hs b/src/lib/ProjectM36/AtomFunctionError.hs --- a/src/lib/ProjectM36/AtomFunctionError.hs +++ b/src/lib/ProjectM36/AtomFunctionError.hs @@ -9,11 +9,13 @@ 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 --- a/src/lib/ProjectM36/AtomFunctions/Primitive.hs +++ b/src/lib/ProjectM36/AtomFunctions/Primitive.hs @@ -4,8 +4,8 @@ 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 @@ -35,23 +35,24 @@ )}, 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], @@ -117,13 +118,21 @@ [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 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)) @@ -136,35 +145,48 @@ 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')) @@ -174,7 +196,7 @@ 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 --- a/src/lib/ProjectM36/AtomType.hs +++ b/src/lib/ProjectM36/AtomType.hs @@ -358,6 +358,9 @@ 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 @@ -448,6 +451,7 @@ RelationalExprAtomType -> True RelationAtomType attrs -> isResolvedAttributes attrs ConstructedAtomType _ tvMap -> all isResolvedType (M.elems tvMap) + SubrelationFoldAtomType typ' -> isResolvedType typ' TypeVariableType _ -> False isResolvedAttributes :: Attributes -> Bool @@ -456,4 +460,5 @@ 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/Atomable.hs b/src/lib/ProjectM36/Atomable.hs --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -256,6 +256,8 @@ = 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 --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -67,6 +67,7 @@ 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 @@ 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 @@ BoolAtomType | UUIDAtomType | RelationAtomType Attributes | + SubrelationFoldAtomType AtomType | ConstructedAtomType TypeConstructorName TypeVarMap | RelationalExprAtomType | TypeVariableType TypeVarName @@ -233,9 +236,9 @@ --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 +507,14 @@ type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker +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 | +data AtomExprBase a = AttributeAtomExpr AttributeName | + SubrelationAttributeAtomExpr AttributeName AttributeName | NakedAtomExpr !Atom | - FunctionAtomExpr FunctionName [AtomExprBase a] 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 RelationAtomExpr (RelationalExprBase a) | IfThenAtomExpr (AtomExprBase a) (AtomExprBase a) (AtomExprBase a) | -- if, then, else ConstructedAtomExpr DataConstructorName [AtomExprBase a] a @@ -653,6 +660,7 @@ 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 @@ -679,6 +687,7 @@ 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 --- a/src/lib/ProjectM36/DataTypes/Interval.hs +++ b/src/lib/ProjectM36/DataTypes/Interval.hs @@ -40,6 +40,7 @@ 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 @@ 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 --- a/src/lib/ProjectM36/DataTypes/Primitive.hs +++ b/src/lib/ProjectM36/DataTypes/Primitive.hs @@ -51,3 +51,4 @@ 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/SQL/Null.hs b/src/lib/ProjectM36/DataTypes/SQL/Null.hs --- a/src/lib/ProjectM36/DataTypes/SQL/Null.hs +++ b/src/lib/ProjectM36/DataTypes/SQL/Null.hs @@ -4,7 +4,6 @@ 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 = 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 @@ 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/DataTypes/Sorting.hs b/src/lib/ProjectM36/DataTypes/Sorting.hs --- a/src/lib/ProjectM36/DataTypes/Sorting.hs +++ b/src/lib/ProjectM36/DataTypes/Sorting.hs @@ -30,6 +30,8 @@ UUIDAtomType -> False RelationalExprAtomType -> False RelationAtomType _ -> False + SubrelationFoldAtomType{} -> False ConstructedAtomType _ _ -> False TypeVariableType _ -> False + diff --git a/src/lib/ProjectM36/FunctionalDependency.hs b/src/lib/ProjectM36/FunctionalDependency.hs --- a/src/lib/ProjectM36/FunctionalDependency.hs +++ b/src/lib/ProjectM36/FunctionalDependency.hs diff --git a/src/lib/ProjectM36/HashSecurely.hs b/src/lib/ProjectM36/HashSecurely.hs --- a/src/lib/ProjectM36/HashSecurely.hs +++ b/src/lib/ProjectM36/HashSecurely.hs @@ -50,6 +50,7 @@ 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,6 +139,7 @@ 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 @@ -165,6 +167,7 @@ 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 --- a/src/lib/ProjectM36/NormalizeExpr.hs +++ b/src/lib/ProjectM36/NormalizeExpr.hs @@ -112,6 +112,7 @@ 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 diff --git a/src/lib/ProjectM36/ReferencedTransactionIds.hs b/src/lib/ProjectM36/ReferencedTransactionIds.hs --- a/src/lib/ProjectM36/ReferencedTransactionIds.hs +++ b/src/lib/ProjectM36/ReferencedTransactionIds.hs @@ -96,6 +96,7 @@ case expr of AttributeAtomExpr{} -> mempty NakedAtomExpr{} -> mempty + SubrelationAttributeAtomExpr{} -> mempty FunctionAtomExpr _ args marker -> S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args)) RelationAtomExpr rExpr -> diff --git a/src/lib/ProjectM36/Relation/Parse/CSV.hs b/src/lib/ProjectM36/Relation/Parse/CSV.hs --- a/src/lib/ProjectM36/Relation/Parse/CSV.hs +++ b/src/lib/ProjectM36/Relation/Parse/CSV.hs @@ -134,7 +134,10 @@ 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 diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -51,8 +51,6 @@ import GHC.Paths #endif ---import Debug.Trace - data DatabaseContextExprDetails = CountUpdatedTuples databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc @@ -855,18 +853,22 @@ 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 +-- first argumentr is starting value, second argument is relationatom evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName' arguments tid) = do argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments context <- gfDatabaseContextForMarker tid @@ -895,6 +897,12 @@ 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 @@ -909,7 +917,7 @@ 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 @@ -923,10 +931,17 @@ 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 (FunctionAtomExpr funcName' atomArgs transId) = do funcs <- atomFunctions <$> gfDatabaseContextForMarker transId @@ -941,7 +956,8 @@ 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 + throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType) handler err = throwError err lift (except $ atomTypeVerify fArg arg) `catchError` handler ) (zip3 funcArgTypes argTypes [1..]) @@ -989,6 +1005,11 @@ verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType = lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom) +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 @@ -996,7 +1017,8 @@ 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 + throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType) handler err = throwError err verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..] @@ -1237,7 +1259,6 @@ 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 @@ -1462,6 +1483,7 @@ instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where resolve orig@AttributeAtomExpr{} = pure orig + resolve orig@SubrelationAttributeAtomExpr{} = pure orig resolve orig@NakedAtomExpr{} = pure orig resolve (FunctionAtomExpr nam atomExprs marker) = FunctionAtomExpr nam <$> mapM resolve atomExprs <*> pure marker diff --git a/src/lib/ProjectM36/SQL/Convert.hs b/src/lib/ProjectM36/SQL/Convert.hs --- a/src/lib/ProjectM36/SQL/Convert.hs +++ b/src/lib/ProjectM36/SQL/Convert.hs @@ -555,7 +555,7 @@ (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 @@ 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 = func "sql_equals" case rexpr of IntegerLiteral{} -> wrongType IntegerAtomType DoubleLiteral{} -> wrongType DoubleAtomType @@ -650,7 +653,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ lookupOperator :: Bool -> OperatorName -> ConvertM ([AtomExpr] -> AtomExpr) lookupOperator isPrefix op@(OperatorName nam) | isPrefix = do - let f n args = FunctionAtomExpr n args () + let f = func case nam of ["-"] -> pure $ f "sql_negate" _ -> throwSQLE $ NoSuchSQLOperatorError op @@ -960,7 +963,7 @@ Just match -> pure match other -> throwSQLE $ NotSupportedError ("function name: " <> T.pack (show other)) where - f n args = FunctionAtomExpr 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"), @@ -974,7 +977,7 @@ ("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. @@ -1082,6 +1085,7 @@ case expr of x@AttributeAtomExpr{} -> x --potential rename x@NakedAtomExpr{} -> x + x@SubrelationAttributeAtomExpr{} -> x FunctionAtomExpr fname args () -> FunctionAtomExpr fname (pushAtom <$> args) () RelationAtomExpr e -> RelationAtomExpr (push e) IfThenAtomExpr ifE thenE elseE -> IfThenAtomExpr (pushAtom ifE) (pushAtom thenE) (pushAtom elseE) @@ -1300,7 +1304,7 @@ 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 +1393,14 @@ 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 = @@ -1479,21 +1483,20 @@ 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 | 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 + [SubrelationAttributeAtomExpr "_sql_aggregate" attrName] 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 - where - callF fname args = FunctionAtomExpr fname args () diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -437,6 +437,7 @@ isStaticAtomExpr :: AtomExpr -> Bool isStaticAtomExpr NakedAtomExpr{} = True +isStaticAtomExpr SubrelationAttributeAtomExpr{} = False isStaticAtomExpr ConstructedAtomExpr{} = True isStaticAtomExpr AttributeAtomExpr{} = False isStaticAtomExpr FunctionAtomExpr{} = False diff --git a/src/lib/ProjectM36/TransGraphRelationalExpression.hs b/src/lib/ProjectM36/TransGraphRelationalExpression.hs --- a/src/lib/ProjectM36/TransGraphRelationalExpression.hs +++ b/src/lib/ProjectM36/TransGraphRelationalExpression.hs @@ -122,6 +122,7 @@ 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 diff --git a/src/lib/ProjectM36/Transaction/Persist.hs b/src/lib/ProjectM36/Transaction/Persist.hs --- a/src/lib/ProjectM36/Transaction/Persist.hs +++ b/src/lib/ProjectM36/Transaction/Persist.hs @@ -69,6 +69,9 @@ 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" @@ -93,7 +96,7 @@ relationVariables = relvars, typeConstructorMapping = typeCons, notifications = notifs, - atomFunctions = atomFuncs, + atomFunctions = atomFuncs, dbcFunctions = dbcFuncs, registeredQueries = registeredQs } newSchemas = Schemas newContext sschemas diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -517,7 +517,7 @@ let newContext = DatabaseContext { inclusionDependencies = incDeps, relationVariables = relVars, - atomFunctions = atomFuncs, + atomFunctions = atomFuncs, dbcFunctions = dbcFuncs, notifications = notifs, typeConstructorMapping = types, diff --git a/src/lib/ProjectM36/TransactionGraph/Merge.hs b/src/lib/ProjectM36/TransactionGraph/Merge.hs --- a/src/lib/ProjectM36/TransactionGraph/Merge.hs +++ b/src/lib/ProjectM36/TransactionGraph/Merge.hs @@ -62,7 +62,7 @@ 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 --- a/src/lib/ProjectM36/Tuple.hs +++ b/src/lib/ProjectM36/Tuple.hs @@ -61,7 +61,6 @@ 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) @@ -222,3 +221,6 @@ 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 --- a/src/lib/ProjectM36/WithNameExpr.hs +++ b/src/lib/ProjectM36/WithNameExpr.hs @@ -84,6 +84,7 @@ 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 diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -24,6 +24,7 @@ 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 @@ (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 @@ ("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 @@ "(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 @@ --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 --- a/test/TutorialD/InterpreterTest.hs +++ b/test/TutorialD/InterpreterTest.hs @@ -95,7 +95,8 @@ testShowDDL, testRegisteredQueries, testCrossJoin, - testIfThenExpr + testIfThenExpr, + testSubrelationAttributeAtomExpr ] simpleRelTests :: Test @@ -184,14 +185,14 @@ --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 @@ 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 @@ 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