project-m36 0.5.1 → 0.6
raw patch · 29 files changed
+471/−64 lines, 29 filesdep ~aesondep ~basedep ~cassavasetup-changed
Dependency ranges changed: aeson, base, cassava, distributed-process, megaparsec, stm-containers, uuid
Files
- Changelog.markdown +5/−0
- README.markdown +1/−0
- Setup.hs +0/−2
- project-m36.cabal +17/−5
- src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +13/−0
- src/bin/ProjectM36/Server/WebSocket.hs +7/−0
- src/bin/TutorialD/Interpreter/Base.hs +10/−0
- src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +38/−1
- src/bin/TutorialD/Interpreter/Types.hs +3/−5
- src/lib/ProjectM36/Atomable.hs +20/−6
- src/lib/ProjectM36/Attribute.hs +4/−0
- src/lib/ProjectM36/Base.hs +9/−6
- src/lib/ProjectM36/Client.hs +33/−1
- src/lib/ProjectM36/DataFrame.hs +173/−0
- src/lib/ProjectM36/DataTypes/Sorting.hs +30/−0
- src/lib/ProjectM36/Error.hs +1/−0
- src/lib/ProjectM36/Persist.hs +8/−5
- src/lib/ProjectM36/Relation/Show/Term.hs +0/−10
- src/lib/ProjectM36/Server.hs +1/−0
- src/lib/ProjectM36/Server/EntryPoints.hs +6/−0
- src/lib/ProjectM36/Server/RemoteCallTypes.hs +3/−0
- src/lib/ProjectM36/TransactionGraph.hs +1/−1
- src/lib/ProjectM36/Tuple.hs +0/−7
- test/DataFrame.hs +61/−0
- test/Relation/Atomable.hs +9/−1
- test/Relation/Basic.hs +0/−0
- test/TransactionGraph/Persist.hs +5/−4
- test/TutorialD/Interpreter.hs +11/−10
- test/TutorialD/Interpreter/TestBase.hs +2/−0
Changelog.markdown view
@@ -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
README.markdown view
@@ -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)
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
project-m36.cabal view
@@ -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/
src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs view
@@ -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,
src/bin/ProjectM36/Server/WebSocket.hs view
@@ -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
src/bin/TutorialD/Interpreter/Base.hs view
@@ -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
src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs view
@@ -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
src/bin/TutorialD/Interpreter/Types.hs view
@@ -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 [] <|>
src/lib/ProjectM36/Atomable.hs view
@@ -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
src/lib/ProjectM36/Attribute.hs view
@@ -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
src/lib/ProjectM36/Base.hs view
@@ -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)
src/lib/ProjectM36/Client.hs view
@@ -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)+
+ src/lib/ProjectM36/DataFrame.hs view
@@ -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 <>+ "<tr><th></th></tr>" <>+ "<tr><td></td></tr>" <> + tablefooter <> "</table>"+ | L.null (tuples df) && L.null (attributes df) = style <>+ tablestart <>+ "<tr><th></th></tr>" <>+ tablefooter <> + "</table>"+ | otherwise = style <>+ tablestart <> + attributesAsHTML (attributes df) (orders df) <> + tuplesAsHTML (tuples df) <> + tablefooter <> + "</table>"+ where+ cardinality = T.pack (show (length (tuples df)))+ style = "<style>.pm36dataframe {empty-cells: show;} .pm36dataframe tbody td, .pm36relation th { border: 1px solid black;}</style>"+ tablefooter = "<tfoot><tr><td colspan=\"100%\">" <> cardinality <> " tuples</td></tr></tfoot>"+ tablestart = "<table class=\"pm36dataframe\"\">"++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 = "<tr>" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <> "</tr>"+ where+ tupleFrag tup = "<td>" <> atomAsHTML (snd tup) <> "</td>"+ atomAsHTML (RelationAtom rel) = RelHTML.relationAsHTML rel+ atomAsHTML atom = atomToText atom++attributesAsHTML :: Attributes -> [AttributeOrder] -> T.Text+attributesAsHTML attrs orders' = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"+ where+ oneAttrHTML attr = "<th>" <> prettyAttribute attr <> ordering (attributeName attr) <> "</th>"+ ordering attrName = " " <> case L.find (\(AttributeOrder nam _) -> nam == attrName) orders' of+ Nothing -> "(arb)"+ Just (AttributeOrder _ AscendingOrder) -> "(asc)"+ Just (AttributeOrder _ DescendingOrder) -> "(desc)"
+ src/lib/ProjectM36/DataTypes/Sorting.hs view
@@ -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+
src/lib/ProjectM36/Error.hs view
@@ -62,6 +62,7 @@ | AtomTypeNameInUseError AtomTypeName | IncompletelyDefinedAtomTypeWithConstructorError | AtomTypeNameNotInUseError AtomTypeName+ | AttributeNotSortableError Attribute | FunctionNameInUseError AtomFunctionName | FunctionNameNotInUseError AtomFunctionName | EmptyCommitError
src/lib/ProjectM36/Persist.hs view
@@ -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
src/lib/ProjectM36/Relation/Show/Term.hs view
@@ -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
src/lib/ProjectM36/Server.hs view
@@ -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),
src/lib/ProjectM36/Server/EntryPoints.hs view
@@ -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 ())
src/lib/ProjectM36/Server/RemoteCallTypes.hs view
@@ -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)
src/lib/ProjectM36/TransactionGraph.hs view
@@ -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
src/lib/ProjectM36/Tuple.hs view
@@ -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)
+ test/DataFrame.hs view
@@ -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+
test/Relation/Atomable.hs view
@@ -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))
test/Relation/Basic.hs view
test/TransactionGraph/Persist.hs view
@@ -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"
test/TutorialD/Interpreter.hs view
@@ -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
test/TutorialD/Interpreter/TestBase.hs view
@@ -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 ()