diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,8 @@ +# 2019-01-08 (v0.6) + +* fix atom type parsing to support more complex data types +* add [data frames](docs/dataframes.markdown) to support server-side sort ordering, limits, and offsets + # 2018-10-03 (v0.5.1) * fix atom function type validation diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -68,6 +68,7 @@ 1. [Transaction Graph Operators](docs/transaction_graph_operators.markdown) 1. [ProjectM36.Client Library](docs/projectm36_client_library.markdown) +1. [Data Frames for Sorting](docs/dataframes.markdown) 1. [Adding New Data Types](docs/new_datatypes.markdown) 1. [Database-Manipulating Functions](docs/database_context_functions.markdown) 1. [Serving Remote ProjectM36 Databases](docs/server_mode.markdown) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/project-m36.cabal b/project-m36.cabal --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,5 +1,5 @@ Name: project-m36 -Version: 0.5.1 +Version: 0.6 License: PublicDomain Build-Type: Simple Homepage: https://github.com/agentm/project-m36 @@ -29,7 +29,7 @@ Default: False Library - Build-Depends: base>=4.8 && < 4.12, ghc >= 7.8 && < 8.5, 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, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.2, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256 + Build-Depends: base>=4.8 && < 4.12, ghc >= 7.8 && < 8.5, 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, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256 Exposed-Modules: ProjectM36.Error, ProjectM36.Transaction, ProjectM36.TransactionGraph, @@ -38,6 +38,7 @@ ProjectM36.TransactionGraph.Merge, ProjectM36.TransGraphRelationalExpression, ProjectM36.Base, + ProjectM36.DataFrame, ProjectM36.Attribute, ProjectM36.AttributeNames, ProjectM36.Tuple, @@ -76,6 +77,7 @@ ProjectM36.Tupleable, ProjectM36.DataConstructorDef, ProjectM36.DataTypes.Basic, + ProjectM36.DataTypes.Sorting, ProjectM36.DataTypes.Day, ProjectM36.DataTypes.DateTime, ProjectM36.DataTypes.Either, @@ -101,11 +103,13 @@ ProjectM36.FileLock, ProjectM36.FSType, ProjectM36.Arbitrary - GHC-Options: -Wall -rdynamic + GHC-Options: -Wall -rdynamic if os(windows) Build-Depends: Win32 >= 2.5.4.1 Other-Modules: ProjectM36.Win32Handle else + --219- too many exported symbols under Windows and GHC 8.4 + GHC-Options: -rdynamic C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c Build-Depends: unix CC-Options: -fPIC @@ -176,7 +180,7 @@ TutorialD.Interpreter.SchemaOperator main-is: TutorialD/tutd.hs CC-Options: -fPIC - GHC-Options: -Wall -rdynamic -threaded + GHC-Options: -Wall -threaded Hs-Source-Dirs: ./src/bin Default-Language: Haskell2010 Default-Extensions: OverloadedStrings @@ -501,4 +505,12 @@ if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall - +Test-Suite test-dataframe + Default-Language: Haskell2010 + Main-Is: test/DataFrame.hs + 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.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups + Default-Extensions: OverloadedStrings + GHC-Options: -Wall -threaded + Hs-Source-Dirs: ./src/bin, ., test/ diff --git a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs --- a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +++ b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs @@ -4,6 +4,7 @@ module ProjectM36.Server.RemoteCallTypes.Json where import ProjectM36.AtomFunctionError import ProjectM36.Base +import ProjectM36.DataFrame import ProjectM36.DatabaseContextFunctionError import ProjectM36.DataTypes.Primitive import ProjectM36.Error @@ -62,6 +63,18 @@ instance ToJSON SchemaIsomorph instance FromJSON SchemaIsomorph + +instance ToJSON DataFrame +instance FromJSON DataFrame + +instance ToJSON DataFrameTuple +instance FromJSON DataFrameTuple + +instance ToJSON AttributeOrder +instance FromJSON AttributeOrder + +instance ToJSON Order +instance FromJSON Order instance ToJSON Atom where toJSON atom@(IntegerAtom i) = object [ "type" .= atomTypeForAtom atom, diff --git a/src/bin/ProjectM36/Server/WebSocket.hs b/src/bin/ProjectM36/Server/WebSocket.hs --- a/src/bin/ProjectM36/Server/WebSocket.hs +++ b/src/bin/ProjectM36/Server/WebSocket.hs @@ -10,6 +10,7 @@ import qualified Network.WebSockets as WS import ProjectM36.Server.RemoteCallTypes.Json () import ProjectM36.Client.Json () +import ProjectM36.DataFrame import ProjectM36.Relation.Show.Term import ProjectM36.Relation.Show.HTML import Data.Aeson @@ -94,6 +95,12 @@ 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)])) + -- get current schema and head name for client promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName) promptInfo sessionId conn = do 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 @@ -13,6 +13,7 @@ import ProjectM36.Base import ProjectM36.AtomType import ProjectM36.Relation +import ProjectM36.DataFrame #if MIN_VERSION_megaparsec(6,0,0) import Text.Megaparsec.Char @@ -59,6 +60,7 @@ pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^" maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength TIO.putStr ("ERR:" <> errString) +displayOpResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame) #if MIN_VERSION_megaparsec(6,0,0) type Parser = Parsec Void Text @@ -124,6 +126,13 @@ integer = Lex.signed spaceConsumer Lex.integer #endif +natural :: Parser Integer +#if MIN_VERSION_megaparsec(6,0,0) +natural = Lex.decimal <* spaceConsumer +#else +natural = Lex.integer <* spaceConsumer +#endif + float :: Parser Double float = Lex.float @@ -161,6 +170,7 @@ DisplayResult StringType | DisplayIOResult (IO ()) | DisplayRelationResult Relation | + DisplayDataFrameResult DataFrame | DisplayErrorResult StringType | DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text QuietSuccessResult 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 @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} module TutorialD.Interpreter.RODatabaseContextOperator where import ProjectM36.Base +import qualified ProjectM36.DataFrame as DF import ProjectM36.Error import ProjectM36.InclusionDependency import qualified ProjectM36.Client as C @@ -24,6 +25,7 @@ ShowRelationVariables :: RODatabaseContextOperator ShowAtomFunctions :: RODatabaseContextOperator ShowDatabaseContextFunctions :: RODatabaseContextOperator + ShowDataFrame :: DF.DataFrameExpr -> RODatabaseContextOperator Quit :: RODatabaseContextOperator deriving (Show) @@ -79,6 +81,7 @@ <|> showTypesP <|> showAtomFunctionsP <|> showDatabaseContextFunctionsP + <|> showDataFrameP <|> quitP --logically, these read-only operations could happen purely, but not if a remote call is required @@ -146,6 +149,12 @@ Left err -> pure $ DisplayErrorResult (T.pack (show err)) Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel)) +evalRODatabaseContextOp sessionId conn (ShowDataFrame dfExpr) = do + eDataFrame <- C.executeDataFrameExpr sessionId conn dfExpr + case eDataFrame of + Left err -> pure (DisplayErrorResult (T.pack (show err))) + Right dframe -> pure (DisplayDataFrameResult dframe) + evalRODatabaseContextOp _ _ Quit = pure QuitResult interpretRODatabaseContextOp :: C.SessionId -> C.Connection -> T.Text -> IO TutorialDOperatorResult @@ -153,4 +162,32 @@ Left err -> pure $ DisplayErrorResult (T.pack (show err)) Right parsed -> evalRODatabaseContextOp sessionId conn parsed - +showDataFrameP :: Parser RODatabaseContextOperator +showDataFrameP = do + reservedOp ":showdataframe" + relExpr <- relExprP + reservedOp "orderby" + attrOrdersExpr <- attrOrdersExprP + mbOffset <- optional offsetP + mbLimit <- optional limitP + pure $ ShowDataFrame (DF.DataFrameExpr relExpr attrOrdersExpr mbOffset mbLimit) + + +offsetP :: Parser Integer +offsetP = do + reservedOp "offset" + natural + +limitP :: Parser Integer +limitP = do + reservedOp "limit" + natural + +attrOrdersExprP :: Parser [DF.AttributeOrderExpr] +attrOrdersExprP = braces (sepBy attrOrderExprP comma) + +attrOrderExprP :: Parser DF.AttributeOrderExpr +attrOrderExprP = DF.AttributeOrderExpr <$> identifier <*> 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/Types.hs b/src/bin/TutorialD/Interpreter/Types.hs --- a/src/bin/TutorialD/Interpreter/Types.hs +++ b/src/bin/TutorialD/Interpreter/Types.hs @@ -24,8 +24,7 @@ -- data *Either a b* = Left *a* | Right *b* dataConstructorDefArgP :: Parser DataConstructorDefArg -dataConstructorDefArgP = parens (DataConstructorDefTypeConstructorArg <$> typeConstructorP) <|> - DataConstructorDefTypeConstructorArg <$> typeConstructorP <|> +dataConstructorDefArgP = DataConstructorDefTypeConstructorArg <$> (monoTypeConstructorP <|> parens typeConstructorP) <|> DataConstructorDefTypeVarNameArg <$> uncapitalizedIdentifier -- relation{a Int} in type construction (no tuples parsed) @@ -44,9 +43,8 @@ -- *Either Int Text*, *Int* typeConstructorP :: Parser TypeConstructor typeConstructorP = relationTypeConstructorP <|> - TypeVariable <$> uncapitalizedIdentifier <|> - ADTypeConstructor <$> capitalizedIdentifier <*> many (parens typeConstructorP <|> - monoTypeConstructorP) + ADTypeConstructor <$> capitalizedIdentifier <*> many (monoTypeConstructorP <|> parens typeConstructorP) <|> + monoTypeConstructorP monoTypeConstructorP :: Parser TypeConstructor monoTypeConstructorP = ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|> 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 @@ -4,7 +4,6 @@ --http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data --instances to marshal Haskell ADTs to ConstructedAtoms and back import ProjectM36.Base -import ProjectM36.DataTypes.Primitive import ProjectM36.DataTypes.List import ProjectM36.DataTypes.NonEmptyList import ProjectM36.DataTypes.Maybe @@ -12,13 +11,13 @@ import GHC.Generics import qualified Data.Map as M import qualified Data.Text as T +import qualified Data.Vector as V import Control.DeepSeq (NFData) import Data.Binary import Control.Applicative import Data.Time.Calendar import Data.ByteString (ByteString) import Data.Time.Clock -import Data.Maybe import Data.Proxy import qualified Data.List.NonEmpty as NE @@ -242,10 +241,25 @@ getConstructorsG = undefined getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons] where - tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType - primitiveAType = toAtomType (Proxy :: Proxy a) - primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) acc -> if typ == primitiveAType then Just name else acc) Nothing primitiveTypeConstructorMapping) - + tCons = typeToTypeConstructor $ toAtomType (Proxy :: Proxy a) + +typeToTypeConstructor :: AtomType -> TypeConstructor +typeToTypeConstructor x@IntAtomType = PrimitiveTypeConstructor "Int" x +typeToTypeConstructor x@IntegerAtomType = PrimitiveTypeConstructor "Integer" x +typeToTypeConstructor x@DoubleAtomType = PrimitiveTypeConstructor "Double" x +typeToTypeConstructor x@TextAtomType = PrimitiveTypeConstructor "Text" x +typeToTypeConstructor x@DayAtomType = PrimitiveTypeConstructor "Day" x +typeToTypeConstructor x@DateTimeAtomType = PrimitiveTypeConstructor "DateTime" x +typeToTypeConstructor x@ByteStringAtomType = PrimitiveTypeConstructor "ByteString" x +typeToTypeConstructor x@BoolAtomType = PrimitiveTypeConstructor "Bool" x +typeToTypeConstructor (RelationAtomType attrs) + = RelationAtomTypeConstructor $ map attrToAttrExpr $ V.toList attrs + where + attrToAttrExpr (Attribute n t) = AttributeAndTypeNameExpr n (typeToTypeConstructor t) () +typeToTypeConstructor (ConstructedAtomType tcName tvMap) + = ADTypeConstructor tcName $ map typeToTypeConstructor (M.elems tvMap) +typeToTypeConstructor (TypeVariableType tvName) = TypeVariable tvName + instance AtomableG U1 where toAtomG = undefined fromAtomG _ _ = pure U1 diff --git a/src/lib/ProjectM36/Attribute.hs b/src/lib/ProjectM36/Attribute.hs --- a/src/lib/ProjectM36/Attribute.hs +++ b/src/lib/ProjectM36/Attribute.hs @@ -7,6 +7,7 @@ import qualified Data.Hashable as Hash import qualified Data.HashSet as HS import qualified Data.Map as M +import Data.Either arity :: Attributes -> Int arity = V.length @@ -73,6 +74,9 @@ attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) attrs of Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName)) Just attr -> Right attr + +isAttributeNameContained :: AttributeName -> Attributes -> Bool +isAttributeNameContained nam attrs = isRight (attributeForName nam attrs) --similar to attributesForNames, but returns error if some names are missing projectionAttributesForNames :: S.Set AttributeName -> Attributes -> Either RelationalError Attributes 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 @@ -77,7 +77,9 @@ TypeVariableType TypeVarName --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor deriving (Eq, NFData, Generic, Binary, Show) - + +instance Ord AtomType where + compare = undefined type TypeVarMap = M.Map TypeVarName AtomType instance Hashable TypeVarMap where @@ -145,13 +147,14 @@ instance Eq RelationTuple where (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual where - atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) attrs of - Nothing -> Nothing - Just index -> tupVec V.!? index - atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) attrs1 + atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) attrs of + Nothing -> Nothing + Just index -> tupVec V.!? index + atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) attrs1 instance NFData RelationTuple where rnf = genericRnf + data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable) instance Eq Relation where @@ -167,7 +170,7 @@ sortedAttrs = map snd (sortedAttributesIndices attrs) instance Binary Relation - + -- | Used to represent the number of tuples in a relation. data RelationCardinality = Countable | Finite Int deriving (Eq, Show, Generic, Ord) diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -16,7 +16,8 @@ closeRemote_, executeRelationalExpr, executeDatabaseContextExpr, - executeDatabaseContextIOExpr, + executeDatabaseContextIOExpr, + executeDataFrameExpr, executeGraphExpr, executeSchemaExpr, executeTransGraphRelationalExpr, @@ -86,6 +87,10 @@ IncDepName, InclusionDependency(..), AttributeName, + DF.DataFrame, + DF.DataFrameExpr, + DF.AttributeOrderExpr, + DF.Order(..), RelationalError(..), RequestTimeoutException(..), RemoteProcessDiedException(..), @@ -103,6 +108,7 @@ import ProjectM36.AtomFunction as AF import ProjectM36.StaticOptimizer import ProjectM36.Key +import qualified ProjectM36.DataFrame as DF import ProjectM36.DatabaseContextFunction as DCF import qualified ProjectM36.IsomorphicSchema as Schema import Control.Monad.State @@ -1137,3 +1143,29 @@ Right _ -> pure (Right val) else -- no updates executed, so don't create a commit pure (Right val) + +executeDataFrameExpr :: SessionId -> Connection -> DF.DataFrameExpr -> IO (Either RelationalError DF.DataFrame) +executeDataFrameExpr sessionId conn@(InProcessConnection _) dfExpr = do + eRel <- executeRelationalExpr sessionId conn (DF.convertExpr dfExpr) + case eRel of + Left err -> pure (Left err) + Right rel -> do + let relAttrs = R.attributes rel + attrName (DF.AttributeOrderExpr name _) = name + order (DF.AttributeOrderExpr _ ord) = ord + orders = map order (DF.orderExprs dfExpr) + attributeForName' = flip attributeForName relAttrs + attrNames = map attrName (DF.orderExprs dfExpr) + verified = forM attrNames attributeForName' + case verified of + Left err -> pure (Left err) + Right attrs -> do + let attrOrders = map (\(attr',order') -> DF.AttributeOrder (attributeName attr') order') (zip attrs orders) + case DF.sortDataFrameBy attrOrders . DF.toDataFrame $ rel of + Left err -> pure (Left err) + Right dFrame -> do + let dFrame' = maybe dFrame (`DF.drop'` dFrame) (DF.offset dfExpr) + dFrame'' = maybe dFrame' (`DF.take'` dFrame') (DF.limit dfExpr) + pure (Right dFrame'') +executeDataFrameExpr sessionId conn@(RemoteProcessConnection _) dfExpr = remoteCall conn (ExecuteDataFrameExpr sessionId dfExpr) + diff --git a/src/lib/ProjectM36/DataFrame.hs b/src/lib/ProjectM36/DataFrame.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/DataFrame.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE DeriveGeneric, 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 +import ProjectM36.Attribute as A +import ProjectM36.Error +import qualified ProjectM36.Relation as R +import ProjectM36.Relation.Show.Term +import qualified ProjectM36.Relation.Show.HTML as RelHTML +import ProjectM36.DataTypes.Sorting +import ProjectM36.AtomType +import ProjectM36.Atom +import qualified Data.Vector as V +import GHC.Generics +import qualified Data.List as L +import qualified Data.Set as S +import Data.Maybe +import qualified Data.Text as T +import Data.Binary +import Control.Arrow +import Data.Monoid + +data AttributeOrderExpr = AttributeOrderExpr AttributeName Order deriving (Show, Generic, Binary) +data AttributeOrder = AttributeOrder AttributeName Order deriving (Show, Generic, Binary) +data Order = AscendingOrder | DescendingOrder deriving (Eq, Show, Generic, Binary) + +ascending :: T.Text +ascending = "⬆" + +descending :: T.Text +descending = "⬇" + +arbitrary :: T.Text +arbitrary = "↕" + +data DataFrame = DataFrame { + orders :: [AttributeOrder], + attributes :: Attributes, + tuples :: [DataFrameTuple] + } deriving (Show, Generic, Binary) + +data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom) deriving (Eq, Show, Generic, Binary) + +sortDataFrameBy :: [AttributeOrder] -> DataFrame -> Either RelationalError DataFrame +sortDataFrameBy attrOrders frame = do + attrs <- mapM (\(AttributeOrder nam _) -> A.attributeForName nam (attributes frame)) attrOrders + mapM_ (\attr -> if not (isSortableAtomType (atomType attr)) then + Left (AttributeNotSortableError attr) + else + pure ()) attrs + pure $ DataFrame attrOrders (attributes frame) (sortTuplesBy (compareTupleByAttributeOrders attrOrders) (tuples frame)) + +sortTuplesBy :: (DataFrameTuple -> DataFrameTuple -> Ordering) -> [DataFrameTuple] -> [DataFrameTuple] +sortTuplesBy = L.sortBy + +compareTupleByAttributeOrders :: [AttributeOrder] -> DataFrameTuple -> DataFrameTuple -> Ordering +compareTupleByAttributeOrders attributeOrders tup1 tup2 = + let compare' (AttributeOrder attr order) = if order == DescendingOrder + then compareTupleByOneAttributeName attr tup2 tup1 + else compareTupleByOneAttributeName attr tup1 tup2 + res = map compare' attributeOrders in + fromMaybe EQ (L.find (/= EQ) res) + +compareTupleByOneAttributeName :: AttributeName -> DataFrameTuple -> DataFrameTuple -> Ordering +compareTupleByOneAttributeName attr tuple1 tuple2 = + let eAtom1 = atomForAttributeName attr tuple1 + eAtom2 = atomForAttributeName attr tuple2 in + case eAtom1 of + Left err -> error (show err) + Right atom1 -> + case eAtom2 of + Left err -> error (show err) + Right atom2 -> compareAtoms atom1 atom2 + +atomForAttributeName :: AttributeName -> DataFrameTuple -> Either RelationalError Atom +atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of + Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName)) + Just index -> case tupVec V.!? index of + Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName)) + Just atom -> Right atom + +take' :: Integer -> DataFrame -> DataFrame +take' n df = df { tuples = take (fromInteger n) (tuples df) } + +drop' :: Integer -> DataFrame -> DataFrame +drop' n df = df { tuples = drop (fromInteger n) (tuples df) } + +toDataFrame :: Relation -> DataFrame +toDataFrame (Relation attrs (RelationTupleSet tuples')) = DataFrame [] attrs (map (\(RelationTuple tupAttrs tupVec) -> DataFrameTuple tupAttrs tupVec) tuples') + +fromDataFrame :: DataFrame -> Either RelationalError Relation +fromDataFrame df = R.mkRelation (attributes df) (RelationTupleSet tuples') + where + tuples' = map (\(DataFrameTuple attrs' tupVec) -> RelationTuple attrs' tupVec) (tuples df) + +showDataFrame :: DataFrame -> T.Text +showDataFrame = renderTable . dataFrameAsTable + +--terminal display +dataFrameAsTable :: DataFrame -> Table +dataFrameAsTable df = (header, body) + where + oAttrNames = orderedAttributeNames (attributes df) + oAttrs = orderedAttributes (attributes df) + header = "DF" : map dfPrettyAttribute oAttrs + dfPrettyAttribute attr = prettyAttribute attr <> case L.find (\(AttributeOrder nam _) -> nam == attributeName attr) (orders df) of + Nothing -> arbitrary + Just (AttributeOrder _ AscendingOrder) -> ascending + Just (AttributeOrder _ DescendingOrder) -> descending + body = snd (L.foldl' tupleFolder (1 :: Int,[]) (tuples df)) + tupleFolder (count, acc) tuple = (count + 1, + acc ++ [T.pack (show count) : map (\attrName -> case atomForAttributeName attrName tuple of + Left _ -> "?" + Right atom -> showAtom 0 atom + ) oAttrNames]) + +-- | A Relation can be converted to a DataFrame for sorting, limits, and offsets. +data DataFrameExpr = DataFrameExpr { + convertExpr :: RelationalExpr, + orderExprs :: [AttributeOrderExpr], + offset :: Maybe Integer, + limit :: Maybe Integer + } deriving (Show, Binary, Generic) + +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 +dataFrameAsHTML df + | length (tuples df) == 1 && L.null (attributes df) = style <> + tablestart <> + "" <> + "" <> + tablefooter <> "" + | L.null (tuples df) && L.null (attributes df) = style <> + tablestart <> + "" <> + tablefooter <> + "" + | otherwise = style <> + tablestart <> + attributesAsHTML (attributes df) (orders df) <> + tuplesAsHTML (tuples df) <> + tablefooter <> + "" + where + cardinality = T.pack (show (length (tuples df))) + style = "" + tablefooter = "" <> cardinality <> " tuples" + tablestart = "" + +tuplesAsHTML :: [DataFrameTuple] -> T.Text +tuplesAsHTML = foldr folder "" + where + folder tuple acc = acc <> tupleAsHTML tuple + +tupleAssocs :: DataFrameTuple -> [(AttributeName, Atom)] +tupleAssocs (DataFrameTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec) + + +tupleAsHTML :: DataFrameTuple -> T.Text +tupleAsHTML tuple = "" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <> "" + where + tupleFrag tup = "" + atomAsHTML (RelationAtom rel) = RelHTML.relationAsHTML rel + atomAsHTML atom = atomToText atom + +attributesAsHTML :: Attributes -> [AttributeOrder] -> T.Text +attributesAsHTML attrs orders' = "" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "" + where + oneAttrHTML attr = "" + ordering attrName = " " <> case L.find (\(AttributeOrder nam _) -> nam == attrName) orders' of + Nothing -> "(arb)" + Just (AttributeOrder _ AscendingOrder) -> "(asc)" + Just (AttributeOrder _ DescendingOrder) -> "(desc)" diff --git a/src/lib/ProjectM36/DataTypes/Sorting.hs b/src/lib/ProjectM36/DataTypes/Sorting.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/DataTypes/Sorting.hs @@ -0,0 +1,30 @@ +module ProjectM36.DataTypes.Sorting where +import ProjectM36.Base + +compareAtoms :: Atom -> Atom -> Ordering +compareAtoms (IntegerAtom i1) (IntegerAtom i2) = compare i1 i2 +compareAtoms (IntAtom i1) (IntAtom i2) = compare i1 i2 +compareAtoms (DoubleAtom d1) (DoubleAtom d2) = compare d1 d2 +compareAtoms (TextAtom t1) (TextAtom t2) = compare t1 t2 +compareAtoms (DayAtom d1) (DayAtom d2) = compare d1 d2 +compareAtoms (DateTimeAtom d1) (DateTimeAtom d2) = compare d1 d2 +compareAtoms (ByteStringAtom b1) (ByteStringAtom b2) = compare b1 b2 +compareAtoms (BoolAtom b1) (BoolAtom b2) = compare b1 b2 +compareAtoms (RelationAtom _) _ = EQ +compareAtoms ConstructedAtom{} _ = EQ +compareAtoms _ _ = EQ + +isSortableAtomType :: AtomType -> Bool +isSortableAtomType typ = case typ of + IntAtomType -> True + IntegerAtomType -> True + DoubleAtomType -> True + TextAtomType -> True + DayAtomType -> True + DateTimeAtomType -> True + ByteStringAtomType -> False + BoolAtomType -> True + RelationAtomType _ -> False + ConstructedAtomType _ _ -> False + TypeVariableType _ -> False + diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -62,6 +62,7 @@ | AtomTypeNameInUseError AtomTypeName | IncompletelyDefinedAtomTypeWithConstructorError | AtomTypeNameNotInUseError AtomTypeName + | AttributeNotSortableError Attribute | FunctionNameInUseError AtomFunctionName | FunctionNameNotInUseError AtomFunctionName | EmptyCommitError diff --git a/src/lib/ProjectM36/Persist.hs b/src/lib/ProjectM36/Persist.hs --- a/src/lib/ProjectM36/Persist.hs +++ b/src/lib/ProjectM36/Persist.hs @@ -66,8 +66,14 @@ atomicRename :: FilePath -> FilePath -> IO () atomicRename srcPath dstPath = #if defined(mingw32_HOST_OS) - Win32.moveFileEx srcPath dstPath Win32.mOVEFILE_REPLACE_EXISTING +#if MIN_VERSION_Win32(2,6,0) + let dst = Just dstPath #else + let dst = dstPath +#endif + in + Win32.moveFileEx srcPath dst Win32.mOVEFILE_REPLACE_EXISTING +#else Posix.rename srcPath dstPath #endif @@ -119,13 +125,10 @@ putStrLn "Fd count not supported on this OS." #endif - -fdCount :: IO Int #if FDCOUNTSUPPORTED +fdCount :: IO Int fdCount = do fds <- getDirectoryContents FDDIR pure ((length fds) - 2) -#else --not supported on non-linux -fdCount = pure 0 #endif diff --git a/src/lib/ProjectM36/Relation/Show/Term.hs b/src/lib/ProjectM36/Relation/Show/Term.hs --- a/src/lib/ProjectM36/Relation/Show/Term.hs +++ b/src/lib/ProjectM36/Relation/Show/Term.hs @@ -38,16 +38,6 @@ boxC :: StringType boxC = "┼" -dboxH :: StringType -dboxH = "═" -dboxL :: StringType -dboxL = "╞" -dboxR :: StringType -dboxR = "╡" - -class TermSize a where - termLength :: a -> Int - --represent a relation as a table similar to those drawn by Date type Cell = StringType type Table = ([Cell], [[Cell]]) --header, body diff --git a/src/lib/ProjectM36/Server.hs b/src/lib/ProjectM36/Server.hs --- a/src/lib/ProjectM36/Server.hs +++ b/src/lib/ProjectM36/Server.hs @@ -26,6 +26,7 @@ apiHandlers = [ handleCall (\conn (ExecuteHeadName sessionId) -> handleExecuteHeadName ti sessionId conn), handleCall (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr ti sessionId conn expr), + handleCall (\conn (ExecuteDataFrameExpr sessionId expr) -> handleExecuteDataFrameExpr ti sessionId conn expr), handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr ti sessionId conn expr), handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr ti sessionId conn expr), handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr ti sessionId conn expr), diff --git a/src/lib/ProjectM36/Server/EntryPoints.hs b/src/lib/ProjectM36/Server/EntryPoints.hs --- a/src/lib/ProjectM36/Server/EntryPoints.hs +++ b/src/lib/ProjectM36/Server/EntryPoints.hs @@ -3,6 +3,7 @@ import ProjectM36.IsomorphicSchema import ProjectM36.Client as C import ProjectM36.Error +import ProjectM36.DataFrame import Control.Distributed.Process (Process, ProcessId) import Control.Distributed.Process.ManagedProcess (ProcessReply) import Control.Distributed.Process.ManagedProcess.Server (reply) @@ -33,6 +34,11 @@ handleExecuteRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation) handleExecuteRelationalExpr ti sessionId conn expr = do ret <- timeoutOrDie ti (executeRelationalExpr sessionId conn expr) + reply ret conn + +handleExecuteDataFrameExpr :: Timeout -> SessionId -> Connection -> DataFrameExpr -> Reply (Either RelationalError DataFrame) +handleExecuteDataFrameExpr ti sessionId conn expr = do + ret <- timeoutOrDie ti (executeDataFrameExpr sessionId conn expr) reply ret conn handleExecuteDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError ()) diff --git a/src/lib/ProjectM36/Server/RemoteCallTypes.hs b/src/lib/ProjectM36/Server/RemoteCallTypes.hs --- a/src/lib/ProjectM36/Server/RemoteCallTypes.hs +++ b/src/lib/ProjectM36/Server/RemoteCallTypes.hs @@ -3,6 +3,7 @@ import ProjectM36.Base import ProjectM36.IsomorphicSchema import ProjectM36.TransactionGraph +import ProjectM36.DataFrame import ProjectM36.TransGraphRelationalExpression import ProjectM36.Session import GHC.Generics @@ -17,6 +18,8 @@ data Logout = Logout deriving (Binary, Generic) data ExecuteRelationalExpr = ExecuteRelationalExpr SessionId RelationalExpr + deriving (Binary, Generic) +data ExecuteDataFrameExpr = ExecuteDataFrameExpr SessionId DataFrameExpr deriving (Binary, Generic) data ExecuteDatabaseContextExpr = ExecuteDatabaseContextExpr SessionId DatabaseContextExpr deriving (Binary, Generic) 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 @@ -400,7 +400,7 @@ transA <- transactionForHeadErr headNameA transB <- transactionForHeadErr headNameB disconParent <- transactionForId parentId graph - let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph) + let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph) subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty subGraph' <- filterSubGraph subGraph subHeads case createMergeTransaction stamp newId mergeStrategy subGraph' (transA, transB) of 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 @@ -48,13 +48,6 @@ Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName)) Just atom -> Right atom -{- -- resolve naming clash with Attribute and Relation later -atomTypeForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom -atomTypeForAttributeName attrName tup = do - atom <- atomForAttributeName attrName tup - return $ atomTypeForAtom atom --} - atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> Either RelationalError (V.Vector Atom) atomsForAttributeNames attrNames tuple = V.map (\index -> tupleAtoms tuple V.! index) <$> vectorIndicesForAttributeNames attrNames (tupleAttributes tuple) diff --git a/test/DataFrame.hs b/test/DataFrame.hs new file mode 100644 --- /dev/null +++ b/test/DataFrame.hs @@ -0,0 +1,61 @@ +import ProjectM36.Client +import ProjectM36.DataFrame +import TutorialD.Interpreter.TestBase + +import Test.HUnit +import System.Exit +import qualified Data.Set as S + +testList :: Test +testList = TestList [testOrderBy, testLimit, testOffset] + +main :: IO () +main = do + tcounts <- runTestTT testList + if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess + +testOrderBy :: Test +testOrderBy = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + Right df <- executeDataFrameExpr sessionId dbconn ( + DataFrameExpr { + convertExpr = Project (AttributeNames (S.singleton "status")) (RelationVariable "s" ()), + orderExprs = [AttributeOrderExpr "status" AscendingOrder], + offset = Nothing, + limit = Nothing + }) + let vals = map (\tup -> case atomForAttributeName "status" tup of + Left err -> error (show err) + Right atom -> atom) (tuples df) + assertEqual "sort order of s" [IntegerAtom 10, IntegerAtom 20, IntegerAtom 30] vals + +testOffset :: Test +testOffset = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + Right df <- executeDataFrameExpr sessionId dbconn ( + DataFrameExpr { + convertExpr = Project (AttributeNames (S.singleton "status")) (RelationVariable "s" ()), + orderExprs = [AttributeOrderExpr "status" AscendingOrder], + offset = Just 1, + limit = Nothing + }) + let vals = map (\tup -> case atomForAttributeName "status" tup of + Left err -> error (show err) + Right atom -> atom) (tuples df) + assertEqual "sort + offset" [IntegerAtom 20, IntegerAtom 30] vals + +testLimit :: Test +testLimit = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + Right df <- executeDataFrameExpr sessionId dbconn ( + DataFrameExpr { + convertExpr = Project (AttributeNames (S.singleton "status")) (RelationVariable "s" ()), + orderExprs = [AttributeOrderExpr "status" DescendingOrder], + offset = Nothing, + limit = Just 1 + }) + let vals = map (\tup -> case atomForAttributeName "status" tup of + Left err -> error (show err) + Right atom -> atom) (tuples df) + assertEqual "sort + limit" [IntegerAtom 30] vals + diff --git a/test/Relation/Atomable.hs b/test/Relation/Atomable.hs --- a/test/Relation/Atomable.hs +++ b/test/Relation/Atomable.hs @@ -44,6 +44,9 @@ data Test7T = Test7C (Either Integer Integer) deriving (Show, Generic, Eq, Binary, NFData, Atomable) + +data Test8T = Test8C Test1T + deriving (Show, Generic, Eq, Binary, NFData, Atomable) main :: IO () main = do @@ -51,7 +54,7 @@ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess testList :: Test -testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either] +testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues] -- test some basic data types like int, day, etc. @@ -141,3 +144,8 @@ testNonEmptyInstance = TestCase $ do let example = TestNonEmptyC [3,4,5] assertEqual "NonEmpty instance" example (fromAtom (toAtom example)) + +testNonPrimitiveValues :: Test +testNonPrimitiveValues = TestCase $ do + let example = Test8C (Test1C 3) + assertEqual "non-primitive values" example (fromAtom (toAtom example)) diff --git a/test/Relation/Basic.hs b/test/Relation/Basic.hs --- a/test/Relation/Basic.hs +++ b/test/Relation/Basic.hs diff --git a/test/TransactionGraph/Persist.hs b/test/TransactionGraph/Persist.hs --- a/test/TransactionGraph/Persist.hs +++ b/test/TransactionGraph/Persist.hs @@ -25,8 +25,9 @@ testList :: Test testList = TestList [testBootstrapDB, - testDBSimplePersistence, + testDBSimplePersistence, testFunctionPersistence] + stamp :: UTCTime stamp = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000) @@ -74,7 +75,8 @@ --only Haskell-scripted dbc and atom functions can be serialized testFunctionPersistence :: Test -testFunctionPersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do +testFunctionPersistence = TestCase $ + withSystemTempDirectory "m36testdb" $ \tempdir -> do let dbdir = tempdir "dbdir" connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback [] conn <- assertIOEither $ connectProjectM36 connInfo @@ -85,9 +87,8 @@ ADTypeConstructor "Either" [ADTypeConstructor "AtomFunctionError" [], intTCons]] "(\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom" _ <- assertIOEither $ executeDatabaseContextIOExpr sess conn addfunc - _ <- assertIOEither $ commit sess conn - close conn + --close conn - pauses indefinitely on Windows --re-open the connection to reload the graph conn2 <- assertIOEither $ connectProjectM36 connInfo sess2 <- assertIOEither $ createSessionAtHead conn2 "master" diff --git a/test/TutorialD/Interpreter.hs b/test/TutorialD/Interpreter.hs --- a/test/TutorialD/Interpreter.hs +++ b/test/TutorialD/Interpreter.hs @@ -3,7 +3,7 @@ import TutorialD.Interpreter import TutorialD.Interpreter.Base import Test.HUnit -import ProjectM36.Relation +import ProjectM36.Relation as R import ProjectM36.Tuple import ProjectM36.TupleSet import ProjectM36.Error @@ -121,7 +121,7 @@ simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)] simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntegerAtomType] nestedRelationAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntegerAtomType])] - extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)] + extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (R.attributes suppliersRel)] byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType] groupCountAttrs = A.attributesFromList [Attribute "z" IntegerAtomType] minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntegerAtomType] @@ -133,10 +133,10 @@ else Right tuple) suppliersRel dateExampleRelTests = [("x:=s where true", Right suppliersRel), ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel), - ("x:=s where false", Right $ Relation (attributes suppliersRel) emptyTupleSet), - ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]), + ("x:=s where false", Right $ Relation (R.attributes suppliersRel) emptyTupleSet), + ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (R.attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]), ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntegerAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntegerAtomType]) (V.fromList [IntegerAtom 50])])), - ("x:=s minus (s where status=20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"], [TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]), + ("x:=s minus (s where status=20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"], [TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]), --atom function tests ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel), ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntegerAtom 5, RelationAtom suppliersRel])])), @@ -149,11 +149,11 @@ ("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)])), --boolean function restriction - ("x:=s where ^lt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]), - ("x:=s where ^gt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], + ("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 $ AtomTypeMismatchError IntegerAtomType BoolAtomType), - ("x:=s where ^not(gte(@status,20))", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]), + ("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), --test key syntax @@ -202,6 +202,7 @@ DisplayResult _ -> assertFailure "display?" DisplayIOResult _ -> assertFailure "displayIO?" DisplayRelationResult _ -> assertFailure "displayrelation?" + DisplayDataFrameResult _ -> assertFailure "displaydataframe?" DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?" DisplayErrorResult err -> assertFailure (show err) QuietSuccessResult -> do @@ -522,7 +523,7 @@ -- and executeTutorialD sessionId dbconn "x:=s where status=20 and status=10" eRvAnd <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ()) - let expectedRelAnd = Right (emptyRelationWithAttrs (attributes suppliersRel)) + let expectedRelAnd = Right (emptyRelationWithAttrs (R.attributes suppliersRel)) assertEqual "status 20 and 10" expectedRelAnd eRvAnd testRelationalAttributeNames :: Test @@ -533,7 +534,7 @@ case eRv of Left err -> assertFailure (show err) Right rel -> - assertEqual "attributes from sp" (attributes supplierProductsRel) (attributes rel) + assertEqual "attributes from sp" (R.attributes supplierProductsRel) (R.attributes rel) testSemijoin :: Test testSemijoin = TestCase $ do diff --git a/test/TutorialD/Interpreter/TestBase.hs b/test/TutorialD/Interpreter/TestBase.hs --- a/test/TutorialD/Interpreter/TestBase.hs +++ b/test/TutorialD/Interpreter/TestBase.hs @@ -35,6 +35,7 @@ DisplayResult _ -> putStrLn "xxx" >> assertFailure "display?" DisplayIOResult _ -> putStrLn "z" >> assertFailure "displayIO?" DisplayRelationResult _ -> putStrLn "Y" >> assertFailure "displayrelation?" + DisplayDataFrameResult _ -> putStrLn "DF" >> assertFailure "displaydataframe?" DisplayParseErrorResult _ _ -> putStrLn "X" >> assertFailure "displayparseerrorresult?" DisplayErrorResult err -> putStrLn "asd" >> assertFailure (show tutd ++ ": " ++ show err) QuietSuccessResult -> pure () @@ -49,6 +50,7 @@ DisplayResult _ -> assertFailure "display?" DisplayIOResult _ -> assertFailure "displayIO?" DisplayRelationResult _ -> assertFailure "displayrelation?" + DisplayDataFrameResult _ -> assertFailure "displaydataframe?" DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?" DisplayErrorResult err -> assertBool ("match error on: " ++ unpack err) (matchFunc err) QuietSuccessResult -> pure ()
" <> atomAsHTML (snd tup) <> "
" <> prettyAttribute attr <> ordering (attributeName attr) <> "