From e9f102334de7462e1a7171c776c7884781ded53e Mon Sep 17 00:00:00 2001 From: AgentM Date: Sat, 5 Jan 2019 00:02:49 -0500 Subject: [PATCH] move dataframe creation and sorting to server-side via Client.hs add preliminary test --- project-m36.cabal | 11 +- runghcid.sh | 2 +- src/bin/TutorialD/Interpreter/Base.hs | 11 +- .../Interpreter/RODatabaseContextOperator.hs | 48 +++----- src/lib/ProjectM36/Attribute.hs | 4 + src/lib/ProjectM36/Client.hs | 34 +++++- src/lib/ProjectM36/DataFrame.hs | 108 ++++++++++++++++++ src/lib/ProjectM36/DataTypes/Sorting.hs | 30 +++++ src/lib/ProjectM36/Error.hs | 3 +- src/lib/ProjectM36/Relation/Show/Term.hs | 10 -- src/lib/ProjectM36/Server.hs | 1 + src/lib/ProjectM36/Server/EntryPoints.hs | 8 +- src/lib/ProjectM36/Server/RemoteCallTypes.hs | 5 +- src/lib/ProjectM36/Tuple.hs | 4 +- test/DataFrame.hs | 34 ++++++ test/Relation/Basic.hs | 2 +- test/TutorialD/Interpreter.hs | 2 +- 17 files changed, 262 insertions(+), 55 deletions(-) create mode 100644 src/lib/ProjectM36/DataFrame.hs create mode 100644 src/lib/ProjectM36/DataTypes/Sorting.hs create mode 100644 test/DataFrame.hs diff --git a/project-m36.cabal b/project-m36.cabal index d0aba3a..16c762e 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -77,6 +77,7 @@ Library ProjectM36.Tupleable, ProjectM36.DataConstructorDef, ProjectM36.DataTypes.Basic, + ProjectM36.DataTypes.Sorting, ProjectM36.DataTypes.Day, ProjectM36.DataTypes.DateTime, ProjectM36.DataTypes.Either, @@ -504,4 +505,12 @@ Executable handles 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/runghcid.sh b/runghcid.sh index e457e46..e295820 100755 --- a/runghcid.sh +++ b/runghcid.sh @@ -1,2 +1,2 @@ #!/bin/sh -./.cabal-sandbox/bin/ghcid --command="cabal repl $1" \ No newline at end of file +~/.cabal/bin/ghcid --command="cabal new-repl $1" diff --git a/src/bin/TutorialD/Interpreter/Base.hs b/src/bin/TutorialD/Interpreter/Base.hs index 8a9adfc..38fb9cc 100644 --- a/src/bin/TutorialD/Interpreter/Base.hs +++ b/src/bin/TutorialD/Interpreter/Base.hs @@ -13,6 +13,7 @@ module TutorialD.Interpreter.Base ( import ProjectM36.Base import ProjectM36.AtomType import ProjectM36.Relation +import ProjectM36.DataFrame #if MIN_VERSION_megaparsec(6,0,0) import Text.Megaparsec.Char @@ -59,8 +60,7 @@ displayOpResult (DisplayParseErrorResult mPromptLength err) = do pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^" maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength TIO.putStr ("ERR:" <> errString) -displayOpResult (DisplayDataFrameResult dFrame) = do - TIO.putStrLn (showRelation $ fromDataFrame dFrame) +displayOpResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame) #if MIN_VERSION_megaparsec(6,0,0) type Parser = Parsec Void Text @@ -126,6 +126,13 @@ integer = Lex.signed spaceConsumer Lex.decimal 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 diff --git a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs index d0a6d0c..d28ea65 100644 --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -1,9 +1,7 @@ {-# LANGUAGE GADTs #-} module TutorialD.Interpreter.RODatabaseContextOperator where import ProjectM36.Base -import ProjectM36.Attribute (attributeForName) -import ProjectM36.DataFrame -import ProjectM36.Relation (attributes) +import qualified ProjectM36.DataFrame as DF import ProjectM36.Error import ProjectM36.InclusionDependency import qualified ProjectM36.Client as C @@ -27,7 +25,7 @@ data RODatabaseContextOperator where ShowRelationVariables :: RODatabaseContextOperator ShowAtomFunctions :: RODatabaseContextOperator ShowDatabaseContextFunctions :: RODatabaseContextOperator - ShowDataFrame :: RelationalExpr -> [AttributeOrderExpr] -> Maybe Integer -> Maybe Integer -> RODatabaseContextOperator + ShowDataFrame :: DF.DataFrameExpr -> RODatabaseContextOperator Quit :: RODatabaseContextOperator deriving (Show) @@ -151,27 +149,11 @@ evalRODatabaseContextOp sessionId conn ShowDatabaseContextFunctions = do Left err -> pure $ DisplayErrorResult (T.pack (show err)) Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel)) -evalRODatabaseContextOp sessionId conn (ShowDataFrame expr attrOrdersExpr mbOffset mbLimit) = do - res <- C.executeRelationalExpr sessionId conn expr - case res of - Left err -> pure $ DisplayErrorResult $ T.pack (show err) - Right rel -> do - let relAttrs = attributes rel - attrName (AttributeOrderExpr name _) = name - order (AttributeOrderExpr _ ord) = ord - orders = map order attrOrdersExpr - attributeForName' = flip attributeForName relAttrs - attrNames = map attrName attrOrdersExpr - verified = forM attrNames attributeForName' - case verified of - Left err -> pure $ DisplayErrorResult $ T.pack (show err) - Right attrs -> do - let attrOrders = map (\(attr',order')->AttributeOrder attr' order') (zip attrs orders) - let dFrame = sortDataFrameBy attrOrders . toDataFrame $ rel - let dFrame' = maybe dFrame (`drop'` dFrame) mbOffset - let dFrame'' = maybe dFrame' (`take'` dFrame') mbLimit - pure $ DisplayDataFrameResult $ dFrame'' - +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 @@ -188,24 +170,24 @@ showDataFrameP = do attrOrdersExpr <- attrOrdersExprP mbOffset <- optional offsetP mbLimit <- optional limitP - pure $ ShowDataFrame relExpr attrOrdersExpr mbOffset mbLimit + pure $ ShowDataFrame (DF.DataFrameExpr relExpr attrOrdersExpr mbOffset mbLimit) offsetP :: Parser Integer offsetP = do reservedOp "offset" - integer + natural limitP :: Parser Integer limitP = do reservedOp "limit" - integer + natural -attrOrdersExprP :: Parser [AttributeOrderExpr] +attrOrdersExprP :: Parser [DF.AttributeOrderExpr] attrOrdersExprP = braces (sepBy attrOrderExprP comma) -attrOrderExprP :: Parser AttributeOrderExpr -attrOrderExprP = AttributeOrderExpr <$> identifier <*> orderP +attrOrderExprP :: Parser DF.AttributeOrderExpr +attrOrderExprP = DF.AttributeOrderExpr <$> identifier <*> orderP -orderP :: Parser Order -orderP = (try $ reservedOp "ASC" >> pure ASC) <|> (try $ reservedOp "DESC" >> pure DESC) <|> pure ASC +orderP :: Parser DF.Order +orderP = try (reservedOp "ascending" >> pure DF.AscendingOrder) <|> try (reservedOp "descending" >> pure DF.DescendingOrder) <|> pure DF.AscendingOrder diff --git a/src/lib/ProjectM36/Attribute.hs b/src/lib/ProjectM36/Attribute.hs index 9e9553b..f96c7ed 100644 --- a/src/lib/ProjectM36/Attribute.hs +++ b/src/lib/ProjectM36/Attribute.hs @@ -7,6 +7,7 @@ import qualified Data.Vector as V 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 @@ -74,6 +75,9 @@ attributeForName attrName attrs = case V.find (\attr -> attributeName attr == at 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 projectionAttributesForNames names attrsIn = diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs index d782ceb..8488961 100644 --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -16,7 +16,8 @@ module ProjectM36.Client closeRemote_, executeRelationalExpr, executeDatabaseContextExpr, - executeDatabaseContextIOExpr, + executeDatabaseContextIOExpr, + executeDataFrameExpr, executeGraphExpr, executeSchemaExpr, executeTransGraphRelationalExpr, @@ -86,6 +87,10 @@ module ProjectM36.Client IncDepName, InclusionDependency(..), AttributeName, + DF.DataFrame(..), + DF.DataFrameExpr(..), + DF.AttributeOrderExpr(..), + DF.Order(..), RelationalError(..), RequestTimeoutException(..), RemoteProcessDiedException(..), @@ -103,6 +108,7 @@ import ProjectM36.Atomable 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 @@ withTransaction sessionId conn io successFunc = bracketOnError (pure ()) (const 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 index 0000000..e2cdd44 --- /dev/null +++ b/src/lib/ProjectM36/DataFrame.hs @@ -0,0 +1,108 @@ +{-# 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 ProjectM36.DataTypes.Sorting +import ProjectM36.AtomType +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 + +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) + +data DataFrame = DataFrame Attributes [DataFrameTuple] deriving (Show, Generic, Binary) + +data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom) deriving (Eq, Show, Generic, Binary) + +attributes :: DataFrame -> Attributes +attributes (DataFrame attrs _) = attrs + +tuples :: DataFrame -> [DataFrameTuple] +tuples (DataFrame _ tups) = tups + +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 (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 (DataFrame attrs tuples') = DataFrame attrs (take (fromInteger n) tuples') + +drop' :: Integer -> DataFrame -> DataFrame +drop' n (DataFrame attrs tuples') = DataFrame attrs (drop (fromInteger n) tuples') + +toDataFrame :: Relation -> DataFrame +toDataFrame (Relation attrs (RelationTupleSet tuples')) = DataFrame attrs (map (\(RelationTuple tupAttrs tupVec) -> DataFrameTuple tupAttrs tupVec) tuples') + +fromDataFrame :: DataFrame -> Either RelationalError Relation +fromDataFrame (DataFrame attrs dftuples) = R.mkRelation attrs (RelationTupleSet tuples') + where + tuples' = map (\(DataFrameTuple attrs' tupVec) -> RelationTuple attrs' tupVec) dftuples + +--terminal display +dataFrameAsTable :: DataFrame -> Table +dataFrameAsTable (DataFrame attrs tups) = (header, body) + where + oAttrNames = orderedAttributeNames attrs + oAttrs = orderedAttributes attrs + header = "DF" : map prettyAttribute oAttrs + body = snd (L.foldl' tupleFolder (1 :: Int,[]) tups) + 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]) + +showDataFrame :: DataFrame -> StringType +showDataFrame = renderTable . dataFrameAsTable + +-- | 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) diff --git a/src/lib/ProjectM36/DataTypes/Sorting.hs b/src/lib/ProjectM36/DataTypes/Sorting.hs new file mode 100644 index 0000000..b44b8ab --- /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 index 6bf40e0..6438524 100644 --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -62,6 +62,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName) | AtomTypeNameInUseError AtomTypeName | IncompletelyDefinedAtomTypeWithConstructorError | AtomTypeNameNotInUseError AtomTypeName + | AttributeNotSortableError Attribute | FunctionNameInUseError AtomFunctionName | FunctionNameNotInUseError AtomFunctionName | EmptyCommitError @@ -141,4 +142,4 @@ data SchemaError = RelVarReferencesMissing (S.Set RelVarName) | -- errors returned from the distributed-process call handlers data ServerError = RequestTimeoutError | ProcessDiedError String - deriving (Generic, Binary, Eq) \ No newline at end of file + deriving (Generic, Binary, Eq) diff --git a/src/lib/ProjectM36/Relation/Show/Term.hs b/src/lib/ProjectM36/Relation/Show/Term.hs index e99a964..631775c 100644 --- a/src/lib/ProjectM36/Relation/Show/Term.hs +++ b/src/lib/ProjectM36/Relation/Show/Term.hs @@ -38,16 +38,6 @@ boxBB = "┴" 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 index f959717..af1eea9 100644 --- a/src/lib/ProjectM36/Server.hs +++ b/src/lib/ProjectM36/Server.hs @@ -26,6 +26,7 @@ serverDefinition testBool ti = defaultProcess { 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 index 229b32f..80da0c5 100644 --- a/src/lib/ProjectM36/Server/EntryPoints.hs +++ b/src/lib/ProjectM36/Server/EntryPoints.hs @@ -3,6 +3,7 @@ import ProjectM36.Base hiding (inclusionDependencies) 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) @@ -34,6 +35,11 @@ handleExecuteRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalE 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 ()) handleExecuteDatabaseContextExpr ti sessionId conn dbexpr = do @@ -164,4 +170,4 @@ handleRetrieveTypeConstructorMapping :: Timeout -> SessionId -> Connection -> Re handleRetrieveTypeConstructorMapping ti sessionId conn = do ret <- timeoutOrDie ti (C.typeConstructorMapping sessionId conn) reply ret conn - \ No newline at end of file + diff --git a/src/lib/ProjectM36/Server/RemoteCallTypes.hs b/src/lib/ProjectM36/Server/RemoteCallTypes.hs index 897cc68..aac6305 100644 --- a/src/lib/ProjectM36/Server/RemoteCallTypes.hs +++ b/src/lib/ProjectM36/Server/RemoteCallTypes.hs @@ -3,6 +3,7 @@ module ProjectM36.Server.RemoteCallTypes where import ProjectM36.Base import ProjectM36.IsomorphicSchema import ProjectM36.TransactionGraph +import ProjectM36.DataFrame import ProjectM36.TransGraphRelationalExpression import ProjectM36.Session import GHC.Generics @@ -18,6 +19,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) data ExecuteDatabaseContextIOExpr = ExecuteDatabaseContextIOExpr SessionId DatabaseContextIOExpr @@ -65,4 +68,4 @@ data RetrieveSessionIsDirty = RetrieveSessionIsDirty SessionId data ExecuteAutoMergeToHead = ExecuteAutoMergeToHead SessionId MergeStrategy HeadName deriving (Binary, Generic) data RetrieveTypeConstructorMapping = RetrieveTypeConstructorMapping SessionId - deriving (Binary, Generic) \ No newline at end of file + deriving (Binary, Generic) diff --git a/src/lib/ProjectM36/Tuple.hs b/src/lib/ProjectM36/Tuple.hs index 2f26e0c..a701d1f 100644 --- a/src/lib/ProjectM36/Tuple.hs +++ b/src/lib/ProjectM36/Tuple.hs @@ -188,7 +188,7 @@ verifyTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTup verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs tupleTypes = V.map atomTypeForAtom (tupleAtoms tuple) in if V.length attrs /= V.length tupleTypes then - Left $ TupleAttributeCountMismatchError 0 + Left $ traceShow (attrs, tupleTypes) $ TupleAttributeCountMismatchError 0 else do mapM_ (uncurry atomTypeVerify) (V.zip attrsTypes tupleTypes) Right tuple @@ -207,4 +207,4 @@ reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then --used in Generics derivation for ADTs without named attributes trimTuple :: Int -> RelationTuple -> RelationTuple -trimTuple index (RelationTuple attrs vals) = RelationTuple (V.drop index attrs) (V.drop index vals) \ No newline at end of file +trimTuple index (RelationTuple attrs vals) = RelationTuple (V.drop index attrs) (V.drop index vals) diff --git a/test/DataFrame.hs b/test/DataFrame.hs new file mode 100644 index 0000000..36f2550 --- /dev/null +++ b/test/DataFrame.hs @@ -0,0 +1,34 @@ +import ProjectM36.Client +import ProjectM36.DataFrame (atomForAttributeName, tuples) +import TutorialD.Interpreter.TestBase + +import Test.HUnit +import System.Exit +import qualified Data.Set as S + +testList :: Test +testList = TestList [] + +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 + +--testLimit :: Test diff --git a/test/Relation/Basic.hs b/test/Relation/Basic.hs index b611d77..549620f 100644 --- a/test/Relation/Basic.hs +++ b/test/Relation/Basic.hs @@ -109,4 +109,4 @@ testDuplicateAttributes = TestCase $ do testExistingRelationType :: Test testExistingRelationType = TestCase $ do let typeResult = runReader (typeForRelationalExpr (ExistingRelation relationTrue)) (RelationalExprStateElems DBC.empty) - assertEqual "ExistingRelation with tuples type" (Right relationFalse) typeResult \ No newline at end of file + assertEqual "ExistingRelation with tuples type" (Right relationFalse) typeResult diff --git a/test/TutorialD/Interpreter.hs b/test/TutorialD/Interpreter.hs index 64bbdb6..63a6d7d 100644 --- a/test/TutorialD/Interpreter.hs +++ b/test/TutorialD/Interpreter.hs @@ -640,4 +640,4 @@ testAtomFunctionArgumentMismatch = TestCase $ do expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 5}} where ^gt(@a,1.5)" --wrong argument count let err2 = "FunctionArgumentCountMismatchError" - expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)" \ No newline at end of file + expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)"