@@ -1,8 +1,106 @@
11import ProjectM36.Base
22import Criterion.Main
3+import qualified ProjectM36.Attribute as A
4+import ProjectM36.Relation
5+import ProjectM36.Persist
6+import ProjectM36.RelationalExpression
7+import ProjectM36.Error
8+import ProjectM36.Transaction.Persist
9+import qualified Data.Text as T
10+import qualified Data.Vector as V
11+import Control.Monad.Trans.Reader
12+import qualified ProjectM36.DatabaseContext as DBC
13+import qualified Data.Set as S
14+import Data.Monoid
15+import System.IO.Temp
16+import System.FilePath
17+import System.Directory
18+
19+{-
20+* create a relation
21+* restrict a relation
22+* project a relation
23+* join two relations
24+-}
25+
26+validate :: Either RelationalError a -> a
27+validate (Left err) = error (show err)
28+validate (Right x) = x
29+
30+createRelation :: Int -> Int -> Either RelationalError Relation
31+createRelation attributeCount tupleCount = do
32+ let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1]
33+ tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom (fromIntegral tupleX)))
34+ tuples = map tuple [0 .. tupleCount]
35+ mkRelationDeferVerify attrs (RelationTupleSet tuples)
36+
37+createRelation' :: Int -> Int -> Relation
38+createRelation' x y = validate (createRelation x y)
39+
40+restrictRelationToOneTuple :: Int -> Relation -> Relation
41+restrictRelationToOneTuple match rel = validate (runReader (evalRelationalExpr restriction) exprState)
42+ where
43+ exprState = mkRelationalExprState DBC.empty
44+ restriction = Restrict predicateMatch (ExistingRelation rel)
45+ predicateMatch = AttributeEqualityPredicate "a0" (NakedAtomExpr (IntAtom match))
46+
47+restrictRelationToHalfRelation :: Int -> Relation -> Relation
48+restrictRelationToHalfRelation cutoff rel = validate (runReader (evalRelationalExpr restriction) exprState)
49+ where
50+ exprState = mkRelationalExprState DBC.basicDatabaseContext
51+ restriction = Restrict predicateMatch (ExistingRelation rel)
52+ predicateMatch = AtomExprPredicate (FunctionAtomExpr "lte" [AttributeAtomExpr "a0", NakedAtomExpr (IntAtom cutoff)] ())
53+
54+projectRelationToAttributes :: AttributeNames -> Relation -> Relation
55+projectRelationToAttributes attrNames rel = validate (runReader (evalRelationalExpr projection) exprState)
56+ where
57+ exprState = mkRelationalExprState DBC.empty
58+ projection = Project attrNames (ExistingRelation rel)
59+
60+unionRelations :: Relation -> Relation -> Relation
61+unionRelations relA relB = validate (union relA relB)
62+
63+joinRelations :: Relation -> Relation -> Relation
64+joinRelations relA relB = validate (join relA relB)
65+
66+groupRelation :: AttributeNames -> Relation -> Relation
67+groupRelation attrNames rel = validate (runReader (evalRelationalExpr (Group attrNames "x" (ExistingRelation rel))) exprState)
68+ where
69+ exprState = mkRelationalExprState DBC.empty
70+
71+bigRelAttrNames :: Int -> Int -> AttributeNames
72+bigRelAttrNames start end = AttributeNames (S.fromList (map (\i -> "a" <> T.pack (show i)) [start .. end]))
373
474main :: IO ()
5−main = defaulMain [
75+main = do
76+ tmpDir <- getCanonicalTemporaryDirectory
77+ createDirectoryIfMissing False (tmpDir </> "relvars")
78+ defaultMain [createRel, restrictRel, projectRel, unionRel, joinRel, groupRel, writeRel tmpDir]
79+ where
80+ createRel = bgroup "create" $ map (\tupCount -> bench ("relation 10x" ++ show tupCount) (nf (createRelation' 10) tupCount)) [100, 1000, 10000]
81+ bigrel10000 = createRelation' 10 10000
82+ bigrel1000 = createRelation' 10 1000
83+ bigrel100 = createRelation' 10 100
84+
85+ restrictRel = bgroup "restrict" [restrictOneTupleRel, restrictHalfTuplesRel]
86+ restrictOneTupleRel = bench "restrict relation 10x10000 to 10x1" (nf (restrictRelationToOneTuple 5000) bigrel10000)
87+ restrictHalfTuplesRel = bench "restrict relation 10x10000 to 10x5000" (nf (restrictRelationToHalfRelation 5000) bigrel10000)
88+
89+ projectRel = bgroup "project" [projectOneAttr, projectHalfAttrs]
90+ projectOneAttr = bench "project 10x1000 to 1x1000" (nf (projectRelationToAttributes (bigRelAttrNames 0 0)) bigrel1000)
91+ projectHalfAttrs = bench "project 10x1000 to 5x1000" (nf (projectRelationToAttributes (bigRelAttrNames 0 4)) bigrel1000)
92+
93+ unionRel = bgroup "union" [unionIdenticalRelations1000, unionIdenticalRelations10000]
94+ unionIdenticalRelations1000 = bench "union identical 10x1000" (nf (unionRelations bigrel1000) bigrel1000)
95+ unionIdenticalRelations10000 = bench "union identical 10x10000" (nf (unionRelations bigrel10000) bigrel10000)
96+
97+ joinRel = bgroup "join" [joinIdenticalRelations100]
98+ joinIdenticalRelations100 = bench "join identical 10x100" (nf (joinRelations bigrel100) bigrel100)
99+
100+ groupRel = bgroup "group" [group100]
101+ group100 = bench "group 10x100" (nf (groupRelation (bigRelAttrNames 1 9)) bigrel100)
6102
7−]
103+ writeRel tmpDir = bgroup "write" [writeRel10000 tmpDir]
104+ writeRel10000 tmpDir = bench "write 10x1000" $ nfIO (writeRelVar FsyncDiskSync tmpDir ("x", bigrel10000))
8105
106+