git.iko.soy/project-m36
on master help sign in
WIP vectorize Attributes and Tuples
03c23d9AgentM
ProjectM36/Atom.hs+11−2
compare with master
unifiedsplit
@@ -1,4 +1,13 @@
1module ProjectM36.Atom where
1module ProjectM36.Atom where
2−--import ProjectM36.Base
2+import ProjectM36.Base
3−--import ProjectM36.Attribute
3+import ProjectM36.Error
4+
5+relationForAtom :: Atom -> Either RelationalError Relation
6+relationForAtom (RelationAtom rel) = Right rel
7+relationForAtom _ = Left $ AttributeIsNotRelationValuedError ""
8+
9+atomTypeForAtom :: Atom -> AtomType
10+atomTypeForAtom (StringAtom _) = StringAtomType
11+atomTypeForAtom (IntAtom _) = IntAtomType
12+atomTypeForAtom (RelationAtom (Relation attributes _)) = RelationAtomType attributes
4
13
ProjectM36/Attribute.hs+92−15
@@ -1,19 +1,90 @@
1module ProjectM36.Attribute where
1module ProjectM36.Attribute where
2import ProjectM36.Base
2import ProjectM36.Base
3−import qualified Data.Map as M
3+import ProjectM36.Error
4import qualified Data.Set as S
4import qualified Data.Set as S
5import qualified Data.List as L
5import qualified Data.List as L
6+import qualified Data.Vector as V
7+import qualified Data.Hashable as Hash
8+import qualified Data.HashSet as HS
9+import Data.Maybe
10+
11+arity :: Attributes -> Int
12+arity = V.length
13+
14+emptyAttributes :: Attributes
15+emptyAttributes = V.empty
16+
17+null :: Attributes -> Bool
18+null = V.null
19+
20+--merges duplicates
21+attributesFromList :: [Attribute] -> Attributes
22+attributesFromList attrList = mergedAttributes
23+ where
24+ mergedAttributes = V.reverse $ V.foldr (\attr acc -> if containsAttributeName (attributeName attr) acc then
25+ acc
26+ else
27+ acc `V.snoc` attr
28+ ) V.empty $ V.fromList attrList
29+ containsAttributeName name attrs = isJust $ V.find (\attr -> attributeName attr == name) attrs
30+
31+attributeName :: Attribute -> AttributeName
32+attributeName (Attribute name _) = name
33+
34+isRelationAtomType :: AtomType -> Bool
35+isRelationAtomType (RelationAtomType _) = True
36+isRelationAtomType _ = False
37+
38+--hm- no error-checking here
39+addAttribute :: Attribute -> Attributes -> Attributes
40+addAttribute attr attrs = attrs `V.snoc` attr
41+
42+--if some attribute names overlap but the types do not, then spit back an error
43+joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes
44+joinAttributes attrs1 attrs2 = if V.length (vectorUniqueify overlappingAttributes) /= V.length overlappingAttributes then
45+ Left $ TupleAttributeTypeMismatchError overlappingAttributes
46+ else
47+ Right $ attrs1 V.++ otherAttributes
48+ where
49+ (overlappingAttributes, otherAttributes) = V.partition (\attr -> V.elem attr attrs2) attrs1
50+
51+addAttributes :: Attributes -> Attributes -> Attributes
52+addAttributes = (V.++)
53+
54+deleteAttributeName :: AttributeName -> Attributes -> Attributes
55+deleteAttributeName attrName = V.filter (\attr -> attributeName attr /= attrName)
6
56
7renameAttribute :: AttributeName -> Attribute -> Attribute
57renameAttribute :: AttributeName -> Attribute -> Attribute
8renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo
58renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo
9
59
10−remapWithAttributes :: S.Set AttributeName -> M.Map AttributeName Atom -> M.Map AttributeName Atom
60+renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes
11−remapWithAttributes attrs m = M.intersection m hollowMap
61+renameAttributes oldAttrName newAttrName attrs = V.map renamer attrs
12 where
62 where
13− hollowMap = M.fromList $ zip (S.toList attrs) (repeat "")
63+ renamer attr = if attributeName attr == oldAttrName then
64+ renameAttribute newAttrName attr
65+ else
66+ attr
67+
68+atomTypeForAttributeName :: AttributeName -> Attributes -> Maybe AtomType
69+atomTypeForAttributeName attrName attrs = case attr of
70+ (Just (Attribute _ atomType)) -> Just atomType
71+ _ -> Nothing
72+ where
73+ attr = attributeForName attrName attrs
74+
75+attributeForName :: AttributeName -> Attributes -> Maybe Attribute
76+attributeForName attrName attrs = V.find ((attrName ==) . attributeName) attrs
14
77
78+attributesForNames :: S.Set AttributeName -> Attributes -> Attributes
79+attributesForNames attrNameSet attrs = V.foldr folder V.empty attrs
80+ where
81+ folder attr acc = if S.member (attributeName attr) attrNameSet then
82+ acc `V.snoc` attr
83+ else
84+ acc
85+
15attributeNameSet :: Attributes -> S.Set AttributeName
86attributeNameSet :: Attributes -> S.Set AttributeName
16−attributeNameSet = M.keysSet
87+attributeNameSet attrVec = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) attrVec
17
88
18--checks if set s1 is wholly contained in the set s2
89--checks if set s1 is wholly contained in the set s2
19attributesContained :: Attributes -> Attributes -> Bool
90attributesContained :: Attributes -> Attributes -> Bool
@@ -35,14 +106,20 @@ sortedAttributeNameList :: S.Set AttributeName -> [AttributeName]
35sortedAttributeNameList attrNameSet= L.sort $ S.toList attrNameSet
106sortedAttributeNameList attrNameSet= L.sort $ S.toList attrNameSet
36
107
37-- take two attribute sets and return an attribute set with the attributes which do not match
108-- take two attribute sets and return an attribute set with the attributes which do not match
38−-- bug: missing attributes don't show up (?)
109+attributesDifference :: Attributes -> Attributes -> Attributes
39−attributesDifference :: Attributes -> Attributes -> Attributes
110+attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)
40−attributesDifference attrA attrB = M.union mismatchA missingB
111+ where
41− where
112+ diff a b = (a L.\\ b) ++ (b L.\\ a)
42− mismatchA = M.foldrWithKey folder M.empty attrA
113+
43− missingB = M.difference attrA attrB
114+vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a
44− folder :: AttributeName -> Attribute -> Attributes -> Attributes
115+vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn
45− folder attrName attrinA acc = if M.notMember attrName attrB || M.lookup attrName attrB /= Just attrinA then
116+
46− M.insert attrName attrinA acc
117+--check that each attribute only appears once
118+verifyAttributes :: Attributes -> Either RelationalError Attributes
119+verifyAttributes attrs = if collapsedAttrs /= attrs then
120+ Left $ TupleAttributeTypeMismatchError (attributesDifference collapsedAttrs attrs)
47 else
121 else
48− acc
122+ Right attrs
123+ where
124+ collapsedAttrs = vectorUniqueify attrs
125+
ProjectM36/Base.hs+46−10
@@ -9,45 +9,81 @@ import Data.UUID (UUID)
9import Control.DeepSeq (NFData, rnf)
9import Control.DeepSeq (NFData, rnf)
10import Control.DeepSeq.Generics (genericRnf)
10import Control.DeepSeq.Generics (genericRnf)
11import GHC.Generics (Generic)
11import GHC.Generics (Generic)
12+import qualified Data.Vector as V
13+import qualified Data.List as L
12
14
13data Atom = StringAtom String |
15data Atom = StringAtom String |
14 IntAtom Int |
16 IntAtom Int |
15 RelationAtom Relation deriving (Show, Eq, Generic)
17 RelationAtom Relation deriving (Show, Eq, Generic)
16
18
17−instance NFData Atom where rnf = genericRnf
19+instance NFData Atom where rnf = genericRnf
20+
21+instance Hash.Hashable Atom
18
22
19data AtomType = StringAtomType |
23data AtomType = StringAtomType |
20 IntAtomType |
24 IntAtomType |
21 RelationAtomType Attributes deriving (Eq, Show, Generic)
25 RelationAtomType Attributes deriving (Eq, Show, Generic)
22
26
23instance NFData AtomType where rnf = genericRnf
27instance NFData AtomType where rnf = genericRnf
24−
25−atomTypeForAtom :: Atom -> AtomType
26−atomTypeForAtom (StringAtom _) = StringAtomType
27−atomTypeForAtom (IntAtom _) = IntAtomType
28−atomTypeForAtom (RelationAtom (Relation attributes _)) = RelationAtomType attributes
29
28
30type AttributeName = String
29type AttributeName = String
31type AtomName = String
30type AtomName = String
32
31
33data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)
32data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)
34
33
34+instance Hash.Hashable Attribute where
35+ hashWithSalt salt (Attribute attrName _) = Hash.hashWithSalt salt attrName
36+
35instance NFData Attribute where rnf = genericRnf
37instance NFData Attribute where rnf = genericRnf
36
38
37−type Attributes = M.Map AttributeName Attribute --attributes keys by attribute name for ease of access
39+type Attributes = V.Vector Attribute
40+
41+attributesEqual :: Attributes -> Attributes -> Bool
42+attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2
43+ where
44+ attrsAsSet = HS.fromList . V.toList
45+
46+sortedAttributesIndices :: Attributes -> [(Int, Attribute)]
47+sortedAttributesIndices attrs = L.sortBy (\(_, (Attribute name1 _)) (_,(Attribute name2 _)) -> compare name1 name2) $ V.toList (V.indexed attrs)
38
48
39type RelationTupleSet = HS.HashSet RelationTuple
49type RelationTupleSet = HS.HashSet RelationTuple
40
50
51+--the same hash must be generated for equal tuples so that the hashset equality works
41instance Hash.Hashable RelationTuple where
52instance Hash.Hashable RelationTuple where
42− hashWithSalt salt tup = Hash.hashWithSalt salt (show tup)
53+ hashWithSalt salt (RelationTuple attrs tupVec) = salt `Hash.hashWithSalt`
54+ sortedAttrs `Hash.hashWithSalt`
55+ (V.toList sortedTupVec)
56+ where
57+ sortedAttrsIndices = sortedAttributesIndices attrs
58+ sortedAttrs = map snd sortedAttrsIndices
59+ sortedTupVec = V.map (\(index, _) -> tupVec V.! index) $ V.fromList sortedAttrsIndices
43
60
61+--maybe the attribute->int mapping should be stored once in the relation and then passed down when needed
44−data RelationTuple = RelationTuple (M.Map AttributeName Atom) deriving (Eq, Show, Generic)
62+data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)
63+
64+instance Eq RelationTuple where
65+ (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual
66+ where
67+ atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) attrs of
68+ Nothing -> Nothing
69+ Just index -> tupVec V.!? index
70+ atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) attrs1
45
71
46instance NFData RelationTuple where rnf = genericRnf
72instance NFData RelationTuple where rnf = genericRnf
47
73
48−data Relation = Relation Attributes RelationTupleSet deriving (Show, Eq, Generic)
74+data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic)
75+
76+instance Eq Relation where
77+ Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attributesEqual attrs1 attrs2 && tupSet1 == tupSet2
49
78
50instance NFData Relation where rnf = genericRnf
79instance NFData Relation where rnf = genericRnf
80+
81+instance Hash.Hashable Relation where
82+ hashWithSalt salt (Relation attrs tupSet) = salt `Hash.hashWithSalt`
83+ sortedAttrs `Hash.hashWithSalt`
84+ HS.toList tupSet
85+ where
86+ sortedAttrs = map snd (sortedAttributesIndices attrs)
51
87
52data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic)
88data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic)
53data RelationSizeInfinite = RelationSizeInfinite
89data RelationSizeInfinite = RelationSizeInfinite
ProjectM36/Error.hs+1−1
@@ -2,7 +2,7 @@ module ProjectM36.Error where
2import ProjectM36.Base
2import ProjectM36.Base
3import qualified Data.UUID as U
3import qualified Data.UUID as U
4
4
5−data RelationalError = NoSuchAttributeNameError String
5+data RelationalError = NoSuchAttributeNameError AttributeName
6 | TupleAttributeCountMismatchError Int --attribute name
6 | TupleAttributeCountMismatchError Int --attribute name
7 | TupleAttributeTypeMismatchError Attributes
7 | TupleAttributeTypeMismatchError Attributes
8 | AttributeCountMismatchError Int
8 | AttributeCountMismatchError Int
ProjectM36/Relation.hs+61−130
@@ -1,14 +1,14 @@
1-- this is an implementation of the Relation typeclass which creates a GADT DSL
1-- this is an implementation of the Relation typeclass which creates a GADT DSL
2{-# LANGUAGE GADTs,ExistentialQuantification,NoImplicitPrelude #-}
2{-# LANGUAGE GADTs,ExistentialQuantification,NoImplicitPrelude #-}
3module ProjectM36.Relation where
3module ProjectM36.Relation where
4−import qualified Data.Map as M
5import qualified Data.Set as S
4import qualified Data.Set as S
6import qualified Data.HashSet as HS
5import qualified Data.HashSet as HS
7import Control.Monad
6import Control.Monad
7+import qualified Data.Vector as V
8
8
9import ProjectM36.Base
9import ProjectM36.Base
10import ProjectM36.Tuple
10import ProjectM36.Tuple
11−import ProjectM36.Attribute
11+import qualified ProjectM36.Attribute as A
12import ProjectM36.TupleSet
12import ProjectM36.TupleSet
13import ProjectM36.Error
13import ProjectM36.Error
14import Prelude hiding (join)
14import Prelude hiding (join)
@@ -17,48 +17,48 @@ attributes :: Relation -> Attributes
17attributes (Relation attrs _ ) = attrs
17attributes (Relation attrs _ ) = attrs
18
18
19attributeNames :: Relation -> S.Set AttributeName
19attributeNames :: Relation -> S.Set AttributeName
20−attributeNames (Relation attrs _) = M.keysSet attrs
20+attributeNames (Relation attrs _) = A.attributeNameSet attrs
21
21
22attributeForName :: AttributeName -> Relation -> Maybe Attribute
22attributeForName :: AttributeName -> Relation -> Maybe Attribute
23−attributeForName attrName (Relation attrs _) = M.lookup attrName attrs
23+attributeForName attrName (Relation attrs _) = A.attributeForName attrName attrs
24
24
25attributesForNames :: S.Set AttributeName -> Relation -> Attributes
25attributesForNames :: S.Set AttributeName -> Relation -> Attributes
26−attributesForNames attrNameSet (Relation attrs _) = M.intersection attrs hollowMap
26+attributesForNames attrNameSet (Relation attrs _) = A.attributesForNames attrNameSet attrs
27− where
28− hollowMap = M.fromList $ zip (S.toList attrNameSet) (repeat (Attribute "" StringAtomType))
29
27
30−attributeTypeForName :: AttributeName -> Relation -> Maybe AtomType
28+atomTypeForName :: AttributeName -> Relation -> Maybe AtomType
31−attributeTypeForName attrName rel = case attr of
29+atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs
32− (Just (Attribute _ atomType)) -> Just atomType
33− _ -> Nothing
34− where
35− attr = attributeForName attrName rel
36
30
37atomValueType :: Atom -> AtomType
31atomValueType :: Atom -> AtomType
38atomValueType (StringAtom _) = StringAtomType
32atomValueType (StringAtom _) = StringAtomType
39atomValueType (IntAtom _) = IntAtomType
33atomValueType (IntAtom _) = IntAtomType
40atomValueType (RelationAtom rel) = RelationAtomType (attributes rel)
34atomValueType (RelationAtom rel) = RelationAtomType (attributes rel)
41
35
36+mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation
37+mkRelationFromList attrs atomMatrix = do
38+ tupSet <- mkTupleSetFromList attrs atomMatrix
39+ return $ Relation attrs tupSet
40+
42mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation
41mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation
43mkRelation attrs tupleSet = do
42mkRelation attrs tupleSet = do
44 --check that all tuples have the same keys
43 --check that all tuples have the same keys
45 --check that all tuples have keys (1-N) where N is the attribute count
44 --check that all tuples have keys (1-N) where N is the attribute count
46− case verifyRelationTupleSet attrs tupleSet of
45+ case verifyTupleSet attrs tupleSet of
47 Left err -> Left err
46 Left err -> Left err
48 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet
47 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet
49
48
50relationTrue :: Relation
49relationTrue :: Relation
51−relationTrue = Relation M.empty $ HS.singleton (RelationTuple M.empty)
50+relationTrue = Relation A.emptyAttributes singletonTupleSet
52
51
53relationFalse :: Relation
52relationFalse :: Relation
54−relationFalse = Relation M.empty emptyTupleSet
53+relationFalse = Relation A.emptyAttributes emptyTupleSet
55
54
56madeTrue :: Either RelationalError Relation
55madeTrue :: Either RelationalError Relation
57−madeTrue = mkRelation M.empty (HS.fromList [])
56+madeTrue = mkRelation A.emptyAttributes (HS.fromList [])
58
57
59madeFalse :: Either RelationalError Relation
58madeFalse :: Either RelationalError Relation
60−madeFalse = mkRelation M.empty emptyTupleSet
59+madeFalse = mkRelation A.emptyAttributes emptyTupleSet
61
60
61+{-
62--used for predicate filtering- instead of allowing for tuple types to be floating around in Tutorial D, just created a "singleton value" relation with cardinality and arity 1 for tuple atom comparison purposes
62--used for predicate filtering- instead of allowing for tuple types to be floating around in Tutorial D, just created a "singleton value" relation with cardinality and arity 1 for tuple atom comparison purposes
63singletonValueFromRelation :: Relation -> Either RelationalError Atom
63singletonValueFromRelation :: Relation -> Either RelationalError Atom
64singletonValueFromRelation rel@(Relation _ tupSet) = if cardinality rel /= Countable 1 then
64singletonValueFromRelation rel@(Relation _ tupSet) = if cardinality rel /= Countable 1 then
@@ -71,6 +71,7 @@ singletonValueFromRelation rel@(Relation _ tupSet) = if cardinality rel /= Count
71 value = snd $ head $ M.toList tupMap
71 value = snd $ head $ M.toList tupMap
72 tupMap = tup2Map $ head (HS.toList tupSet)
72 tupMap = tup2Map $ head (HS.toList tupSet)
73 tup2Map (RelationTuple tupmap) = tupmap
73 tup2Map (RelationTuple tupmap) = tupmap
74+-}
74
75
75union :: Relation -> Relation -> Either RelationalError Relation
76union :: Relation -> Relation -> Either RelationalError Relation
76union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
77union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
@@ -83,7 +84,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
83
84
84project :: S.Set AttributeName -> Relation -> Either RelationalError Relation
85project :: S.Set AttributeName -> Relation -> Either RelationalError Relation
85project projectionAttrNames rel =
86project projectionAttrNames rel =
86− if not $ attributeNamesContained projectionAttrNames (attributeNames rel)
87+ if not $ A.attributeNamesContained projectionAttrNames (attributeNames rel)
87 then Left $ AttributeNameMismatchError ""
88 then Left $ AttributeNameMismatchError ""
88 else
89 else
89 relFold folder (Right $ Relation newAttrs HS.empty) rel
90 relFold folder (Right $ Relation newAttrs HS.empty) rel
@@ -94,12 +95,6 @@ project projectionAttrNames rel =
94 Left err -> Left err
95 Left err -> Left err
95 Right acc2 -> union acc2 (Relation newAttrs (HS.singleton (tupleProject projectionAttrNames tupleToProject)))
96 Right acc2 -> union acc2 (Relation newAttrs (HS.singleton (tupleProject projectionAttrNames tupleToProject)))
96
97
97−tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple
98−tupleProject projectAttrs (RelationTuple tupleInMap) = RelationTuple $ M.filterWithKey attrFilter tupleInMap
99− where
100− attrFilter key _ = S.member key projectAttrs
101−
102−--the expensive rename is why I wanted to use IntMap instead of attribute names in the tupleset
103rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
98rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
104rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =
99rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =
105 if not attributeValid
100 if not attributeValid
@@ -109,15 +104,15 @@ rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =
109 else
104 else
110 mkRelation newAttrs newTupSet
105 mkRelation newAttrs newTupSet
111 where
106 where
112− newAttributeInUse = attributeNamesContained (S.singleton newAttrName) (attributeNames rel)
107+ newAttributeInUse = A.attributeNamesContained (S.singleton newAttrName) (attributeNames rel)
113− attributeValid = attributeNamesContained (S.singleton oldAttrName) (attributeNames rel)
108+ attributeValid = A.attributeNamesContained (S.singleton oldAttrName) (attributeNames rel)
114− newAttrs = M.delete oldAttrName $ M.insert newAttrName (renameAttribute newAttrName (oldAttrs M.! oldAttrName)) oldAttrs
109+ newAttrs = A.renameAttributes oldAttrName newAttrName oldAttrs
115 newTupSet = HS.map tupsetmapper oldTupSet
110 newTupSet = HS.map tupsetmapper oldTupSet
116 tupsetmapper tuple = tupleRenameAttribute oldAttrName newAttrName tuple
111 tupsetmapper tuple = tupleRenameAttribute oldAttrName newAttrName tuple
117
112
118--the algebra should return a relation of one attribute and one row with the arity
113--the algebra should return a relation of one attribute and one row with the arity
119arity :: Relation -> Int
114arity :: Relation -> Int
120−arity (Relation attrs _) = M.size attrs
115+arity (Relation attrs _) = A.arity attrs
121
116
122cardinality :: Relation -> RelationCardinality
117cardinality :: Relation -> RelationCardinality
123cardinality (Relation _ tupSet) = Countable (HS.size tupSet)
118cardinality (Relation _ tupSet) = Countable (HS.size tupSet)
@@ -151,31 +146,33 @@ group groupAttrNames newAttrName rel = do
151 nonGroupProjection <- project nonGroupAttrNames rel
146 nonGroupProjection <- project nonGroupAttrNames rel
152 relFold folder (Right $ Relation newAttrs emptyTupleSet) nonGroupProjection
147 relFold folder (Right $ Relation newAttrs emptyTupleSet) nonGroupProjection
153 where
148 where
154− newAttrs = M.insert newAttrName groupAttr (attributesForNames nonGroupAttrNames rel)
149+ newAttrs = A.addAttribute groupAttr (attributesForNames nonGroupAttrNames rel)
155 groupAttr = Attribute newAttrName (RelationAtomType (attributesForNames nonGroupAttrNames rel))
150 groupAttr = Attribute newAttrName (RelationAtomType (attributesForNames nonGroupAttrNames rel))
156− nonGroupAttrNames = nonMatchingAttributeNameSet groupAttrNames (attributeNames rel)
151+ nonGroupAttrNames = A.nonMatchingAttributeNameSet groupAttrNames (attributeNames rel)
157 folder tupleIn acc = case acc of
152 folder tupleIn acc = case acc of
158 Left err -> Left err
153 Left err -> Left err
159 Right acc2 -> union acc2 (Relation newAttrs (HS.singleton (tupleExtend tupleIn (matchingRelTuple tupleIn))))
154 Right acc2 -> union acc2 (Relation newAttrs (HS.singleton (tupleExtend tupleIn (matchingRelTuple tupleIn))))
160 matchingRelTuple groupTuple = case imageRelationFor groupTuple rel of
155 matchingRelTuple groupTuple = case imageRelationFor groupTuple rel of
161− Right rel2 -> RelationTuple $ M.singleton newAttrName (RelationAtom rel2)
156+ Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (RelationAtom rel2))
162 Left _ -> undefined
157 Left _ -> undefined
163
158
164--help restriction function
159--help restriction function
165--returns a subrelation of
160--returns a subrelation of
166restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
161restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
167−restrictEq (RelationTuple tupMap) rel = restrict rfilter rel
162+restrictEq tuple rel = restrict rfilter rel
168 where
163 where
169 rfilter :: RelationTuple -> Bool
164 rfilter :: RelationTuple -> Bool
170− rfilter (RelationTuple tupMap2) = M.isSubmapOf tupMap tupMap2
165+ rfilter tupleIn = tupleIntersection tuple tupleIn /= emptyTuple
171
166
172-- unwrap relation-valued attribute
167-- unwrap relation-valued attribute
173-- return error if relval attrs and nongroup attrs overlap
168-- return error if relval attrs and nongroup attrs overlap
174ungroup :: AttributeName -> Relation -> Either RelationalError Relation
169ungroup :: AttributeName -> Relation -> Either RelationalError Relation
170+ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of
171+ Left err -> Left err
175−ungroup relvalAttrName rel = relFold relFolder (Right $ Relation newAttrs emptyTupleSet) rel
172+ Right relvalAttrs -> relFold relFolder (Right $ Relation newAttrs emptyTupleSet) rel
176− where
173+ where
177− newAttrs = M.union (attributesForRelval relvalAttrName rel) nonGroupAttrs
174+ newAttrs = A.addAttributes relvalAttrs nonGroupAttrs
178− nonGroupAttrs = M.delete relvalAttrName (attributes rel)
175+ nonGroupAttrs = A.deleteAttributeName relvalAttrName (attributes rel)
179 relFolder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation
176 relFolder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation
180 relFolder tupleIn acc = case (tupleUngroup relvalAttrName newAttrs tupleIn) of
177 relFolder tupleIn acc = case (tupleUngroup relvalAttrName newAttrs tupleIn) of
181 Right ungroupRelation -> case acc of
178 Right ungroupRelation -> case acc of
@@ -187,36 +184,20 @@ ungroup relvalAttrName rel = relFold relFolder (Right $ Relation newAttrs emptyT
187
184
188--take an relval attribute name and a tuple and ungroup the relval
185--take an relval attribute name and a tuple and ungroup the relval
189tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation
186tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation
190−tupleUngroup relvalAttrName newAttrs tuple@(RelationTuple tupMap) = case (tupMap M.! relvalAttrName) of
187+tupleUngroup relvalAttrName newAttrs tuple = do
188+ relvalRelation <- relationForAttributeName relvalAttrName tuple
191− (RelationAtom relvalRelation) -> relFold folder (Right $ Relation newAttrs emptyTupleSet) relvalRelation
189+ relFold folder (Right $ Relation newAttrs emptyTupleSet) relvalRelation
192− where
193− nonGroupTupleProjection = tupleProject nonGroupAttrNames tuple
194− nonGroupAttrNames = M.keysSet newAttrs
195− folder tupleIn acc = case acc of
196− Left err -> Left err
197− Right accRel -> union accRel $ Relation newAttrs (HS.singleton (tupleExtend nonGroupTupleProjection tupleIn))
198− relvalRelation = unsafeRelValFromAtom $ tupleAtomForAttribute tuple relvalAttrName
199− where
200− unsafeRelValFromAtom :: Atom -> Relation
201− unsafeRelValFromAtom (RelationAtom rel) = rel
202− unsafeRelValFromAtom (StringAtom _) = undefined
203− unsafeRelValFromAtom (IntAtom _) = undefined
204− _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName
205−
206−--this is a hack needed because the relation attributes are untyped so we must dig into the relval to get the attribute names
207−attributesForRelval :: AttributeName -> Relation -> Attributes
208−attributesForRelval relvalAttrName (Relation _ tupleSet) = attributes relvalRelation
209 where
190 where
210− --this is only temporarily needed until the Relation stores the types of the columns as data- hack alert
191+ nonGroupTupleProjection = tupleProject nonGroupAttrNames tuple
211− --find a tuple with attributes to steal to ungroup
192+ nonGroupAttrNames = A.attributeNameSet newAttrs
212− oneTuple :: RelationTupleSet -> RelationTuple
193+ folder tupleIn acc = case acc of
213− oneTuple tupSet = head $ HS.toList $ HS.filter (\(RelationTuple tupMap) -> M.size tupMap > 0) tupSet
194+ Left err -> Left err
214− relvalRelation = unsafeRelValFromAtom $ tupleAtomForAttribute (oneTuple tupleSet) relvalAttrName
195+ Right accRel -> union accRel $ Relation newAttrs (HS.singleton (tupleExtend nonGroupTupleProjection tupleIn))
215− where
196+
216− unsafeRelValFromAtom :: Atom -> Relation
197+attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes
217− unsafeRelValFromAtom (RelationAtom rel) = rel
198+attributesForRelval relvalAttrName (Relation attrs _) = case A.atomTypeForAttributeName relvalAttrName attrs of
218− unsafeRelValFromAtom (StringAtom _) = undefined
199+ (Just (RelationAtomType relAttrs)) -> Right relAttrs
219− unsafeRelValFromAtom (IntAtom _) = undefined
200+ _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName
220
201
221restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation
202restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation
222restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset
203restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset
@@ -225,11 +206,11 @@ restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rf
225--after changing from string atoms, there needs to be a type-checking step!
206--after changing from string atoms, there needs to be a type-checking step!
226--this is a "nested loop" scan as described by the postgresql documentation
207--this is a "nested loop" scan as described by the postgresql documentation
227join :: Relation -> Relation -> Either RelationalError Relation
208join :: Relation -> Relation -> Either RelationalError Relation
228−join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = Right $ Relation newAttrs newTupSet
209+join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = do
229− where
230− newAttrs = M.union attrs1 attrs2
231− newTupSet = HS.foldr tupleSetJoiner emptyTupleSet tupSet1
210+ let newTupSet = HS.foldr tupleSetJoiner emptyTupleSet tupSet1
232− tupleSetJoiner tuple1 accumulator = HS.union (singleTupleSetJoin tuple1 tupSet2) accumulator
211+ tupleSetJoiner tuple1 accumulator = HS.union (singleTupleSetJoin tuple1 tupSet2) accumulator
212+ newAttrs <- A.joinAttributes attrs1 attrs2
213+ return $ Relation newAttrs newTupSet
233
214
234--a map should NOT change the structure of a relation, so attributes should be constant
215--a map should NOT change the structure of a relation, so attributes should be constant
235relMap :: (RelationTuple -> RelationTuple) -> Relation -> Either RelationalError Relation
216relMap :: (RelationTuple -> RelationTuple) -> Relation -> Either RelationalError Relation
@@ -242,7 +223,7 @@ relMap mapper (Relation attrs tupleSet) = do
242 let remappedTuple = mapper tupleIn
223 let remappedTuple = mapper tupleIn
243 if tupleAttributes remappedTuple == tupleAttributes tupleIn
224 if tupleAttributes remappedTuple == tupleAttributes tupleIn
244 then Right remappedTuple
225 then Right remappedTuple
245− else Left $ TupleAttributeTypeMismatchError (attributesDifference (tupleAttributes tupleIn) attrs)
226+ else Left $ TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs)
246
227
247--in the future, the mapper should be able to return a RelationalError likely
228--in the future, the mapper should be able to return a RelationalError likely
248relMogrify :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation
229relMogrify :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation
@@ -258,12 +239,8 @@ relFold folder acc (Relation _ tupleSet) = HS.foldr folder acc tupleSet
258imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
239imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
259imageRelationFor matchTuple rel = do
240imageRelationFor matchTuple rel = do
260 restricted <- restrictEq matchTuple rel --restrict across matching tuples
241 restricted <- restrictEq matchTuple rel --restrict across matching tuples
261− project (nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)) restricted --project across attributes not in rel
242+ project (A.nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)) restricted --project across attributes not in rel
262
243
263−imageRelationTest :: Either RelationalError Relation
264−imageRelationTest = imageRelationFor tup s
265− where
266− tup = mkRelationTuple (S.fromList ["SNAME", "CITY", "S#"]) (M.fromList [("SNAME", StringAtom "Smith"), ("S#", StringAtom "S1"), ("CITY", StringAtom "London")])
267
244
268--returns a relation-valued attribute image relation for each tuple in rel1
245--returns a relation-valued attribute image relation for each tuple in rel1
269--algorithm:
246--algorithm:
@@ -278,61 +255,15 @@ imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSe
278 tupleSetJoiner tup1 acc = undefined
255 tupleSetJoiner tup1 acc = undefined
279-}
256-}
280
257
281−{- C.J. Date's canonical example relvars -}
282−
283−relvarS :: Either RelationalError Relation
284−relvarS = mkRelation attributeSet tupleSet
285− where
286− attributeSet = M.fromList [("S#", Attribute "S#" StringAtomType),
287− ("SNAME", Attribute "SNAME" StringAtomType),
288− ("STATUS", Attribute "STATUS" IntAtomType),
289− ("CITY", Attribute "CITY" StringAtomType)]
290− tupleSet = HS.fromList $ mkRelationTuples attributeSet [
291− M.fromList [("S#", StringAtom "S1") , ("SNAME", StringAtom "Smith"), ("STATUS", IntAtom 20) , ("CITY", StringAtom "London")],
292− M.fromList [("S#", StringAtom "S2"), ("SNAME", StringAtom "Jones"), ("STATUS", IntAtom 10), ("CITY", StringAtom "Paris")],
293− M.fromList [("S#", StringAtom "S3"), ("SNAME", StringAtom "Blake"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Paris")],
294− M.fromList [("S#", StringAtom "S4"), ("SNAME", StringAtom "Clark"), ("STATUS", IntAtom 20), ("CITY", StringAtom "London")],
295− M.fromList [("S#", StringAtom "S5"), ("SNAME", StringAtom "Adams"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Athens")]]
296−
297−s :: Relation
298−s = case relvarS of { Right r -> r }
299−
300−relvarP :: Either RelationalError Relation
301−relvarP = mkRelation attributeSet tupleSet
302− where
303− attributeSet = M.fromList [("P#", Attribute "P#" StringAtomType),
304− ("PNAME", Attribute "PNAME" StringAtomType),
305− ("COLOR", Attribute "COLOR" StringAtomType),
306− ("WEIGHT", Attribute "WEIGHT" StringAtomType),
307− ("CITY", Attribute "CITY" StringAtomType)]
308− tupleSet = HS.fromList $ mkRelationTuples attributeSet [
309− M.fromList [("P#", StringAtom "P1"), ("PNAME", StringAtom "Nut"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 12), ("CITY", StringAtom "London")]
310− ]
311−p :: Relation
312−p = case relvarP of { Right r -> r }
313−
314−relvarSP :: Either RelationalError Relation
315−relvarSP = mkRelation attributeSet tupleSet
316− where
317− attributeSet = M.fromList [("S#", Attribute "S#" StringAtomType),
318− ("P#", Attribute "P#" StringAtomType),
319− ("QTY", Attribute "QTY" StringAtomType)]
320− tupleSet = HS.fromList $ mkRelationTuples attributeSet [
321− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P1"), ("QTY", IntAtom 300)]
322− ]
323−
324−sp :: Relation
325−sp = case relvarSP of { Right r -> r }
326−
327−
328-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long
258-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long
329-- this is useful for performance and resource usage testing
259-- this is useful for performance and resource usage testing
330matrixRelation :: Int -> Int -> Either RelationalError Relation
260matrixRelation :: Int -> Int -> Either RelationalError Relation
331−matrixRelation attributeCount tupleCount = mkRelation attributeSet tupleSet
261+matrixRelation attributeCount tupleCount = do
332− where
333− attributeSet = M.fromList $ map (\c-> (show c, Attribute (show c) IntAtomType)) [0 .. attributeCount]
262+ let attrs = A.attributesFromList $ map (\c-> Attribute (show c) IntAtomType) [0 .. attributeCount]
334− tupleSet = HS.fromList $ mkRelationTuples attributeSet $ map (\c -> tuple c) [0 .. tupleCount]
263+ tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX))
335− tuple tupleX = M.fromList $ map (\c -> (show c, IntAtom tupleX)) [0..attributeCount]
264+ tupleSet <- mkTupleSet attrs $ map (\c -> tuple c) [0 .. tupleCount]
265+ mkRelation attrs tupleSet
266+
336
267
337
268
338
269
ProjectM36/Relation/Show/CSV.hs+3−2
@@ -1,9 +1,10 @@
1module ProjectM36.Relation.Show.CSV where
1module ProjectM36.Relation.Show.CSV where
2import ProjectM36.Base
2import ProjectM36.Base
3import Data.Csv
3import Data.Csv
4−import qualified Data.Map as M
4+import ProjectM36.Tuple
5import qualified Data.HashSet as HS
5import qualified Data.HashSet as HS
6import qualified Data.ByteString.Lazy as BS
6import qualified Data.ByteString.Lazy as BS
7+import qualified Data.Vector as V
7
8
8--maybe support a header in the future
9--maybe support a header in the future
9relationAsCSV :: Relation -> BS.ByteString
10relationAsCSV :: Relation -> BS.ByteString
@@ -13,7 +14,7 @@ tupleSetAsCSV :: RelationTupleSet -> BS.ByteString
13tupleSetAsCSV tupleSet = encode $ HS.toList tupleSet
14tupleSetAsCSV tupleSet = encode $ HS.toList tupleSet
14
15
15instance ToRecord RelationTuple where
16instance ToRecord RelationTuple where
16− toRecord (RelationTuple tupMap) = toRecord $ map toField (M.elems tupMap)
17+ toRecord tuple = toRecord $ map toField (V.toList $ tupleAtoms tuple)
17
18
18instance ToField Atom where
19instance ToField Atom where
19 toField (StringAtom atom) = toField atom
20 toField (StringAtom atom) = toField atom
ProjectM36/Relation/Show/Term.hs+23−14
@@ -4,27 +4,40 @@ import ProjectM36.Base
4import ProjectM36.Tuple
4import ProjectM36.Tuple
5import ProjectM36.Relation
5import ProjectM36.Relation
6import qualified Data.Set as S
6import qualified Data.Set as S
7−import qualified Data.Map as M
8import qualified Data.HashSet as HS
7import qualified Data.HashSet as HS
9import qualified Data.List as L
8import qualified Data.List as L
10
9
10+boxV :: String
11boxV = "│"
11boxV = "│"
12+boxH :: String
12boxH = "─"
13boxH = "─"
13
14
15+boxTL :: String
14boxTL = "┌"
16boxTL = "┌"
17+boxTR :: String
15boxTR = "┐"
18boxTR = "┐"
19+boxBL :: String
16boxBL = "└"
20boxBL = "└"
21+boxBR :: String
17boxBR = "┘"
22boxBR = "┘"
18
23
24+boxLB :: String
19boxLB = "├"
25boxLB = "├"
26+boxRB :: String
20boxRB = "┤"
27boxRB = "┤"
28+boxTB :: String
21boxTB = "┬"
29boxTB = "┬"
30+boxBB :: String
22boxBB = "┴"
31boxBB = "┴"
23
32
33+boxC :: String
24boxC = "┼"
34boxC = "┼"
25
35
36+dboxH :: String
26dboxH = "═"
37dboxH = "═"
38+dboxL :: String
27dboxL = "╞"
39dboxL = "╞"
40+dboxR :: String
28dboxR = "╡"
41dboxR = "╡"
29
42
30class TermSize a where
43class TermSize a where
@@ -40,14 +53,14 @@ addRow cells (header,body) = (header, body ++ [cells])
40--calculate maximum per-row and per-column sizes
53--calculate maximum per-row and per-column sizes
41
54
42cellLocations :: Table -> ([Int],[Int]) --column size, row size
55cellLocations :: Table -> ([Int],[Int]) --column size, row size
43−cellLocations tab@(header, body) = (maxWidths, maxHeights)
56+cellLocations tab@(header, _) = (maxWidths, maxHeights)
44 where
57 where
45 cellSizeMatrix = cellSizes tab
58 cellSizeMatrix = cellSizes tab
46 maxWidths = foldl mergeMax (baseSize (length header)) (map fst cellSizeMatrix)
59 maxWidths = foldl mergeMax (baseSize (length header)) (map fst cellSizeMatrix)
47 baseSize num = take num (repeat 0)
60 baseSize num = take num (repeat 0)
48 rowHeights = map snd cellSizeMatrix
61 rowHeights = map snd cellSizeMatrix
49 maxHeights = map (L.maximumBy compare) rowHeights
62 maxHeights = map (L.maximumBy compare) rowHeights
50− mergeMax a b = map (\(a,b) -> max a b) (zip a b)
63+ mergeMax a b = map (\(c,d) -> max c d) (zip a b)
51
64
52--the normal "lines" function returns an empty list for an empty string which is not what we want
65--the normal "lines" function returns an empty list for an empty string which is not what we want
53breakLines :: String -> [String]
66breakLines :: String -> [String]
@@ -67,7 +80,10 @@ relationAsTable rel@(Relation _ tupleSet) = (header, body)
67 header = oAttrs
80 header = oAttrs
68 body :: [[Cell]]
81 body :: [[Cell]]
69 body = HS.foldl' tupleFolder [] tupleSet
82 body = HS.foldl' tupleFolder [] tupleSet
70− tupleFolder acc (RelationTuple tupMap) = acc ++ [map (\n -> showAtom (tupMap M.! n)) oAttrs]
83+ tupleFolder acc tuple = acc ++ [map (\attrName -> case atomForAttributeName attrName tuple of
84+ Left _ -> "?"
85+ Right atom -> showAtom atom
86+ ) oAttrs]
71
87
72showAtom :: Atom -> String
88showAtom :: Atom -> String
73showAtom (StringAtom atom) = atom
89showAtom (StringAtom atom) = atom
@@ -93,7 +109,7 @@ renderHBar left middle end columnLocations = left ++ concat (L.intersperse middl
93leftPaddedString :: Int -> Int -> String -> String
109leftPaddedString :: Int -> Int -> String -> String
94leftPaddedString lineNum size str = paddedLines !! lineNum
110leftPaddedString lineNum size str = paddedLines !! lineNum
95 where
111 where
96− paddedLines = map (\s -> s ++ repeatString (size - length s) " ") (breakLines str ++ repeat "")
112+ paddedLines = map (\line -> line ++ repeatString (size - length line) " ") (breakLines str ++ repeat "")
97
113
98renderRow :: [Cell] -> [Int] -> Int -> String -> String
114renderRow :: [Cell] -> [Int] -> Int -> String -> String
99renderRow cells columnLocations rowHeight interspersed = unlines $ map renderOneLine [0..rowHeight-1]
115renderRow cells columnLocations rowHeight interspersed = unlines $ map renderOneLine [0..rowHeight-1]
@@ -122,14 +138,7 @@ showRelation rel
122 | otherwise = renderTable (relationAsTable rel)
138 | otherwise = renderTable (relationAsTable rel)
123
139
124
140
141+{-
125groupedExample :: Relation
142groupedExample :: Relation
126groupedExample = case group (S.fromList ["CITY"]) "CITYREL" s of {Right rel -> rel}
143groupedExample = case group (S.fromList ["CITY"]) "CITYREL" s of {Right rel -> rel}
127−
144+-}
128−emptyStringExample :: Relation
129−emptyStringExample = case mkRelation attributes tupleSet of
130− Right x -> x
131− _ -> undefined
132− where
133− attributes = M.fromList [("x", Attribute "x" StringAtomType)]
134− tupleSet = HS.singleton $ mkRelationTuple (S.fromList ["x"]) (M.singleton "x" $ StringAtom "")
135−
ProjectM36/RelationalExpression.hs+54−59
@@ -4,6 +4,7 @@ import ProjectM36.Tuple
4import ProjectM36.TupleSet
4import ProjectM36.TupleSet
5import ProjectM36.Base
5import ProjectM36.Base
6import ProjectM36.Error
6import ProjectM36.Error
7+import qualified ProjectM36.Attribute as A
7import qualified Data.Map as M
8import qualified Data.Map as M
8import qualified Data.HashSet as HS
9import qualified Data.HashSet as HS
9import Control.Monad.State hiding (join)
10import Control.Monad.State hiding (join)
@@ -101,69 +102,65 @@ dateExamples = DatabaseContext { inclusionDependencies = HS.empty, -- add foreig
101 suppliers = suppliersRel
102 suppliers = suppliersRel
102 products = productsRel
103 products = productsRel
103 supplierProducts = supplierProductsRel
104 supplierProducts = supplierProductsRel
104−
105+
105−suppliersRel :: Relation
106+suppliersRel :: Relation
106−suppliersRel = case mkRelation attributeSet tupleSet of
107+suppliersRel = case mkRelationFromList attrs atomMatrix of
107 Left _ -> undefined
108 Left _ -> undefined
108 Right rel -> rel
109 Right rel -> rel
109 where
110 where
110− attributeSet = M.fromList [("S#", Attribute "S#" StringAtomType),
111+ attrs = A.attributesFromList [Attribute "S#" StringAtomType,
111− ("SNAME", Attribute "SNAME" StringAtomType),
112+ Attribute "SNAME" StringAtomType,
112− ("STATUS", Attribute "STATUS" IntAtomType),
113+ Attribute "STATUS" IntAtomType,
113− ("CITY", Attribute "CITY" StringAtomType)]
114+ Attribute "CITY" StringAtomType]
114− tupleSet = HS.fromList $ mkRelationTuples attributeSet [
115+ atomMatrix = [
115− M.fromList [("S#", StringAtom "S1") , ("SNAME", StringAtom "Smith"), ("STATUS", IntAtom 20) , ("CITY", StringAtom "London")],
116+ [StringAtom "S1", StringAtom "Smith", IntAtom 20, StringAtom "London"],
116− M.fromList [("S#", StringAtom "S2"), ("SNAME", StringAtom "Jones"), ("STATUS", IntAtom 10), ("CITY", StringAtom "Paris")],
117+ [StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"],
117− M.fromList [("S#", StringAtom "S3"), ("SNAME", StringAtom "Blake"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Paris")],
118+ [StringAtom "S3", StringAtom "Blake", IntAtom 30, StringAtom "Paris"],
118− M.fromList [("S#", StringAtom "S4"), ("SNAME", StringAtom "Clark"), ("STATUS", IntAtom 20), ("CITY", StringAtom "London")],
119+ [StringAtom "S4", StringAtom "Clark", IntAtom 20, StringAtom "London"],
119− M.fromList [("S#", StringAtom "S5"), ("SNAME", StringAtom "Adams"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Athens")]]
120+ [StringAtom "S5", StringAtom "Adams", IntAtom 30, StringAtom "Athens"]]
120−
121+
121−productsRel :: Relation
122+supplierProductsRel :: Relation
122−productsRel = case mkRelation attributeSet tupleSet of
123+supplierProductsRel = case mkRelationFromList attrs matrix of
123 Left _ -> undefined
124 Left _ -> undefined
124 Right rel -> rel
125 Right rel -> rel
125 where
126 where
126− attributeSet = M.fromList [("P#", Attribute "P#" StringAtomType),
127+ attrs = A.attributesFromList [Attribute "S#" StringAtomType,
127− ("PNAME", Attribute "PNAME" StringAtomType),
128− ("COLOR", Attribute "COLOR" StringAtomType),
128+ Attribute "P#" StringAtomType,
129− ("WEIGHT", Attribute "WEIGHT" IntAtomType),
130− ("CITY", Attribute "CITY" StringAtomType)]
129+ Attribute "QTY" StringAtomType]
131− tupleSet = HS.fromList $ mkRelationTuples attributeSet [
130+ matrix = [
132− M.fromList [("P#", StringAtom "P1"), ("PNAME", StringAtom "Nut"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 12), ("CITY", StringAtom "London")],
131+ [StringAtom "S1", StringAtom "P1", IntAtom 300],
133− M.fromList [("P#", StringAtom "P2"), ("PNAME", StringAtom "Bolt"), ("COLOR", StringAtom "Green"), ("WEIGHT", IntAtom 17), ("CITY", StringAtom "Paris")],
132+ [StringAtom "S1", StringAtom "P2", IntAtom 200],
134− M.fromList [("P#", StringAtom "P3"), ("PNAME", StringAtom "Screw"), ("COLOR", StringAtom "Blue"), ("WEIGHT", IntAtom 17), ("CITY", StringAtom "Oslo")],
133+ [StringAtom "S1", StringAtom "P3", IntAtom 400],
135− M.fromList [("P#", StringAtom "P4"), ("PNAME", StringAtom "Screw"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 14), ("CITY", StringAtom "London")],
134+ [StringAtom "S1", StringAtom "P4", IntAtom 200],
136− M.fromList [("P#", StringAtom "P5"), ("PNAME", StringAtom "Cam"), ("COLOR", StringAtom "Blue"), ("WEIGHT", IntAtom 12), ("CITY", StringAtom "Paris")],
135+ [StringAtom "S1", StringAtom "P5", IntAtom 100],
137− M.fromList [("P#", StringAtom "P6"), ("PNAME", StringAtom "Cog"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 19), ("CITY", StringAtom "London")]
136+ [StringAtom "S1", StringAtom "P6", IntAtom 100],
138−
137+ [StringAtom "S2", StringAtom "P1", IntAtom 300],
138+ [StringAtom "S2", StringAtom "P2", IntAtom 400],
139+ [StringAtom "S3", StringAtom "P2", IntAtom 200],
140+ [StringAtom "S4", StringAtom "P2", IntAtom 200],
141+ [StringAtom "S4", StringAtom "P4", IntAtom 300],
142+ [StringAtom "S4", StringAtom "P5", IntAtom 400]
139 ]
143 ]
140−
144+
141−supplierProductsRel :: Relation
145+productsRel :: Relation
142−supplierProductsRel = case mkRelation attributeSet tupleSet of
146+productsRel = case mkRelationFromList attrs matrix of
143 Left _ -> undefined
147 Left _ -> undefined
144 Right rel -> rel
148 Right rel -> rel
145 where
149 where
150+ attrs = A.attributesFromList [Attribute "P#" StringAtomType,
146− attributeSet = M.fromList [("S#", Attribute "S#" StringAtomType),
151+ Attribute "PNAME" StringAtomType,
152+ Attribute "COLOR" StringAtomType,
147− ("P#", Attribute "P#" StringAtomType),
153+ Attribute "WEIGHT" StringAtomType,
148− ("QTY", Attribute "QTY" IntAtomType)]
154+ Attribute "CITY" StringAtomType]
149− tupleSet = HS.fromList $ mkRelationTuples attributeSet [
155+ matrix = [
150− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P1"), ("QTY", IntAtom 300)],
156+ [StringAtom "P1", StringAtom "Nut", StringAtom "Red", IntAtom 12, StringAtom "London"],
151− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P2"), ("QTY", IntAtom 200)],
157+ [StringAtom "P2", StringAtom "Bolt", StringAtom "Green", IntAtom 17, StringAtom "Paris"],
152− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P3"), ("QTY", IntAtom 400)],
158+ [StringAtom "P3", StringAtom "Screw", StringAtom "Blue", IntAtom 17, StringAtom "Oslo"],
153− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P4"), ("QTY", IntAtom 200)],
159+ [StringAtom "P4", StringAtom "Screw", StringAtom "Red", IntAtom 14, StringAtom "London"],
154− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P5"), ("QTY", IntAtom 100)],
160+ [StringAtom "P5", StringAtom "Cam", StringAtom "Blue", IntAtom 12, StringAtom "Paris"],
155− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P6"), ("QTY", IntAtom 100)],
156−
157− M.fromList [("S#", StringAtom "S2"), ("P#", StringAtom "P1"), ("QTY", IntAtom 300)],
161+ [StringAtom "P6", StringAtom "Cog", StringAtom "Red", IntAtom 19, StringAtom "London"]
158− M.fromList [("S#", StringAtom "S2"), ("P#", StringAtom "P2"), ("QTY", IntAtom 400)],
162+ ]
159−
163+
160− M.fromList [("S#", StringAtom "S3"), ("P#", StringAtom "P2"), ("QTY", IntAtom 200)],
161−
162− M.fromList [("S#", StringAtom "S4"), ("P#", StringAtom "P2"), ("QTY", IntAtom 200)],
163− M.fromList [("S#", StringAtom "S4"), ("P#", StringAtom "P4"), ("QTY", IntAtom 300)],
164− M.fromList [("S#", StringAtom "S4"), ("P#", StringAtom "P5"), ("QTY", IntAtom 400)]
165− ]
166−
167--helper function to process relation variable creation/assignment
164--helper function to process relation variable creation/assignment
168setRelVar :: String -> Relation -> DatabaseState (Maybe RelationalError)
165setRelVar :: String -> Relation -> DatabaseState (Maybe RelationalError)
169setRelVar relVarName rel = do
166setRelVar relVarName rel = do
@@ -234,10 +231,8 @@ evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = d
234 makeUpdatedRel relin = do
231 makeUpdatedRel relin = do
235 restrictedPortion <- restrict predicateFunc relin
232 restrictedPortion <- restrict predicateFunc relin
236 unrestrictedPortion <- restrict (not . predicateFunc) relin
233 unrestrictedPortion <- restrict (not . predicateFunc) relin
237− updatedPortion <- relMap tupleUpdater restrictedPortion
234+ updatedPortion <- relMap (updateTuple attrAssignments) restrictedPortion
238 union updatedPortion unrestrictedPortion
235 union updatedPortion unrestrictedPortion
239− tupleUpdater = \(RelationTuple tupMap) -> RelationTuple $ M.union attrAssignments tupMap
240−
241
236
242evalContextExpr (AddInclusionDependency dep) = do
237evalContextExpr (AddInclusionDependency dep) = do
243 currstate <- get
238 currstate <- get
@@ -333,9 +328,9 @@ predicateRestrictionFilter context (RelationalExprPredicate relExpr) = case runS
333 else
328 else
334 Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"
329 Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"
335
330
336−predicateRestrictionFilter _ (AttributeEqualityPredicate attrName atom) = Right $ \(RelationTuple tupMap) -> tupValue tupMap == atom
331+predicateRestrictionFilter _ (AttributeEqualityPredicate attrName atom) = Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of
337− where
332+ Left _ -> False
338− tupValue tupMap = tupMap M.! attrName
333+ Right atom2 -> atom2 == atom
339
334
340
335
341
336
ProjectM36/Transaction/Show.hs+21−22
@@ -5,9 +5,10 @@ import ProjectM36.Tuple
5import ProjectM36.TupleSet
5import ProjectM36.TupleSet
6import ProjectM36.Error
6import ProjectM36.Error
7import ProjectM36.Transaction
7import ProjectM36.Transaction
8−import qualified Data.Map as M
8+import qualified ProjectM36.Attribute as A
9import qualified Data.HashSet as HS
9import qualified Data.HashSet as HS
10import qualified Data.Set as S
10import qualified Data.Set as S
11+import qualified Data.Vector as V
11
12
12showTransactionStructure :: Transaction -> TransactionGraph -> String
13showTransactionStructure :: Transaction -> TransactionGraph -> String
13showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo
14showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo
@@ -25,38 +26,36 @@ showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" trans
25--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
26--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
26graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
27graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
27graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _ transSet) = do
28graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _ transSet) = do
28− tupleSet <- mapM tupleGenerator (S.toList transSet)
29+ tupleMatrix <- mapM tupleGenerator (S.toList transSet)
29− mkRelation attributeSet (HS.fromList tupleSet)
30+ mkRelationFromList attrs tupleMatrix
30 where
31 where
31− attributeSet = M.fromList [("id", Attribute "id" StringAtomType),
32+ attrs = A.attributesFromList [Attribute "id" StringAtomType,
32− ("parents", Attribute "parents" (RelationAtomType parentAttributes)),
33+ Attribute "parents" (RelationAtomType parentAttributes),
33− ("current", Attribute "current" IntAtomType),
34+ Attribute "current" IntAtomType,
34− ("head", Attribute "head" StringAtomType)
35+ Attribute "head" StringAtomType
35− ]
36+ ]
36− parentAttributes = M.fromList [("id", Attribute "id" StringAtomType)]
37+ parentAttributes = A.attributesFromList [Attribute "id" StringAtomType]
37 tupleGenerator transaction = case transactionParentsRelation transaction graph of
38 tupleGenerator transaction = case transactionParentsRelation transaction graph of
38 Left err -> Left err
39 Left err -> Left err
39− Right parentTransRel -> Right $ mkRelationTuple (S.fromList ["id", "parents", "current", "head"]) $
40− (M.fromList
41− [("id", StringAtom $ show (transactionUUID transaction)),
40+ Right parentTransRel -> Right [StringAtom $ show (transactionUUID transaction),
42− ("parents", RelationAtom parentTransRel),
41+ RelationAtom parentTransRel,
43− ("current", IntAtom $ if parentUUID == transactionUUID transaction then 1 else 0),
42+ IntAtom $ if parentUUID == transactionUUID transaction then 1 else 0,
44− ("head", StringAtom $ case headNameForTransaction transaction graph of
43+ StringAtom $ case headNameForTransaction transaction graph of
45− Just headName -> headName
44+ Just headName -> headName
46− Nothing -> "")
45+ Nothing -> ""
47− ])
46+ ]
48
47
49transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
48transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
50transactionParentsRelation trans graph = do
49transactionParentsRelation trans graph = do
51 if isRootTransaction trans graph then do
50 if isRootTransaction trans graph then do
52− mkRelation attributes emptyTupleSet
51+ mkRelation attrs emptyTupleSet
53 else do
52 else do
54 parentTransSet <- parentTransactions trans graph
53 parentTransSet <- parentTransactions trans graph
55 let tupleSet = HS.fromList $ map trans2tuple (S.toList parentTransSet)
54 let tupleSet = HS.fromList $ map trans2tuple (S.toList parentTransSet)
56− mkRelation attributes tupleSet
55+ mkRelation attrs tupleSet
57 where
56 where
58− attributes = M.fromList [("id", Attribute "id" StringAtomType)]
57+ attrs = A.attributesFromList [Attribute "id" StringAtomType]
59− trans2tuple trans2 = mkRelationTuple (S.fromList ["id"]) $ M.singleton "id" (StringAtom (show $ transactionUUID trans2))
58+ trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (StringAtom (show $ transactionUUID trans2))
60
59
61
60
62
61
ProjectM36/Tuple.hs+122−37
@@ -1,53 +1,67 @@
1module ProjectM36.Tuple where
1module ProjectM36.Tuple where
2import ProjectM36.Base
2import ProjectM36.Base
3+import ProjectM36.Error
3import ProjectM36.Attribute
4import ProjectM36.Attribute
5+import ProjectM36.Atom
4
6
5import qualified Data.Map as M
7import qualified Data.Map as M
6import qualified Data.Set as S
8import qualified Data.Set as S
7−import qualified Data.List as L
8import qualified Data.HashSet as HS
9import qualified Data.HashSet as HS
10+import qualified Data.Vector as V
11+import Data.Either (rights)
12+
13+emptyTuple :: RelationTuple
14+emptyTuple = RelationTuple V.empty V.empty
9
15
10tupleSize :: RelationTuple -> Int
16tupleSize :: RelationTuple -> Int
11−tupleSize (RelationTuple m) = M.size m
17+tupleSize (RelationTuple tupAttrs _) = V.length tupAttrs
12
18
13tupleAttributeNameSet :: RelationTuple -> S.Set AttributeName
19tupleAttributeNameSet :: RelationTuple -> S.Set AttributeName
14−tupleAttributeNameSet (RelationTuple tupMap) = M.keysSet tupMap
20+tupleAttributeNameSet (RelationTuple tupAttrs _) = S.fromList $ V.toList $ V.map attributeName tupAttrs
15
21
16tupleAttributes :: RelationTuple -> Attributes
22tupleAttributes :: RelationTuple -> Attributes
17−tupleAttributes (RelationTuple tupMap) = M.mapWithKey mapper tupMap
23+tupleAttributes (RelationTuple tupAttrs _) = tupAttrs
24+
25+-- return atoms in some arbitrary but consistent key order
26+tupleAtoms :: RelationTuple -> V.Vector Atom
27+tupleAtoms (RelationTuple _ tupVec) = tupVec
28+
29+atomForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom
30+atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of
31+ Nothing -> Left $ NoSuchAttributeNameError attrName
32+ Just index -> case tupVec V.!? index of
33+ Nothing -> Left $ NoSuchAttributeNameError attrName
34+ Just atom -> Right atom
35+
36+atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> V.Vector Atom
37+atomsForAttributeNames attrNames tuple = V.foldr folder V.empty attrNames
18 where
38 where
19− mapper key atom = Attribute key (atomTypeForAtom atom)
39+ folder attrName acc = case atomForAttributeName attrName tuple of
40+ Left _ -> acc
41+ Right atom -> V.snoc acc atom
42+
43+relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation
44+relationForAttributeName attrName tuple = if maybe False isRelationAtomType (atomTypeForAttributeName attrName (tupleAttributes tuple)) then
45+ Left $ AttributeIsNotRelationValuedError attrName
46+ else do
47+ atomVal <- atomForAttributeName attrName tuple
48+ relationForAtom atomVal
49+
20
50
21−tupleAtomForAttribute :: RelationTuple -> AttributeName -> Atom
22−tupleAtomForAttribute (RelationTuple tupMap) attrName = tupMap M.! attrName
23
51
24−{-instance Show RelationTuple where
25− show (RelationTuple t) = show $ M.toAscList t-}
26−
27--in case the oldattr does not exist in the tuple, then return the old tuple
52--in case the oldattr does not exist in the tuple, then return the old tuple
28tupleRenameAttribute :: AttributeName -> AttributeName -> RelationTuple -> RelationTuple
53tupleRenameAttribute :: AttributeName -> AttributeName -> RelationTuple -> RelationTuple
29−tupleRenameAttribute oldattr newattr old@(RelationTuple tmap) =
54+tupleRenameAttribute oldattr newattr (RelationTuple tupAttrs tupVec) = RelationTuple newAttrs tupVec
30− if M.notMember oldattr tmap
31− then old
32− else
33− RelationTuple newmap
34 where
55 where
35− newmap = M.insert newattr oldvalue deletedKeyMap
56+ newAttrs = renameAttributes oldattr newattr tupAttrs
36− oldvalue = tmap M.! oldattr
37− deletedKeyMap = M.delete oldattr tmap
38
57
39−--in case the map does not contain the attributes, filter them out
40−mkRelationTuple :: S.Set AttributeName-> M.Map AttributeName Atom -> RelationTuple
58+mkRelationTuple :: Attributes -> V.Vector Atom -> RelationTuple
41−mkRelationTuple attrs attrmap = RelationTuple newMap
59+mkRelationTuple attrs atoms = RelationTuple attrs atoms
42− where
43− --make sure only attributes in the name set are in the tuple
44− --check that Atoms are all of the same type- change to Either return value
45− newMap = remapWithAttributes attrs attrmap
46
60
47−mkRelationTuples :: Attributes -> [M.Map AttributeName Atom] -> [RelationTuple]
61+mkRelationTuples :: Attributes -> [V.Vector Atom] -> [RelationTuple]
48−mkRelationTuples attrs maplist = map mapper maplist
62+mkRelationTuples attrs atomsVec = map mapper atomsVec
49 where
63 where
50− mapper m = RelationTuple $ remapWithAttributes (attributeNameSet attrs) m
64+ mapper = mkRelationTuple attrs
51
65
52singleTupleSetJoin :: RelationTuple -> RelationTupleSet -> RelationTupleSet
66singleTupleSetJoin :: RelationTuple -> RelationTupleSet -> RelationTupleSet
53singleTupleSetJoin tup tupSet = HS.foldr tupleJoiner HS.empty tupSet
67singleTupleSetJoin tup tupSet = HS.foldr tupleJoiner HS.empty tupSet
@@ -57,20 +71,91 @@ singleTupleSetJoin tup tupSet = HS.foldr tupleJoiner HS.empty tupSet
57 Just relTuple -> HS.insert relTuple accumulator
71 Just relTuple -> HS.insert relTuple accumulator
58 where joinedTuple = singleTupleJoin tup tuple2
72 where joinedTuple = singleTupleJoin tup tuple2
59
73
74+-- the keys/values don't need to be resorted
75+-- if the keys share some keys and values, then merge the tuples
60singleTupleJoin :: RelationTuple -> RelationTuple -> Maybe RelationTuple
76singleTupleJoin :: RelationTuple -> RelationTuple -> Maybe RelationTuple
61−singleTupleJoin (RelationTuple tup1) (RelationTuple tup2) = newTuple
77+singleTupleJoin tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = if
78+ V.null keysIntersection || atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2
79+ then
80+ Nothing
81+ else
82+ Just $ RelationTuple newAttrs newVec
83+ where
84+ keysIntersection = V.map attributeName attrsIntersection
85+ attrsIntersection = V.filter (flip V.notElem $ tupAttrs1) tupAttrs2
86+ newAttrs = vectorUnion tupAttrs1 tupAttrs2
87+ newVec = V.map (findAtomForAttributeName . attributeName) newAttrs
88+ --search both tuples for the
89+ findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2]
90+
91+--same consideration as Data.List.union- duplicates in v1 are not de-duped
92+vectorUnion :: (Eq a) => V.Vector a -> V.Vector a -> V.Vector a
93+vectorUnion v1 v2 = V.foldr folder v1 v2
62 where
94 where
63− newTuple = if M.isSubmapOfBy (==) matchingMap tup2 then
95+ folder e acc = if V.elem e v1 then
64− Just $ RelationTuple (M.union tup1 tup2)
96+ acc
65 else
97 else
66− Nothing
98+ V.snoc acc e
67− matchingMap = M.intersection tup1 tup2
68−
69
99
100+--precondition- no overlap in attributes
70tupleExtend :: RelationTuple -> RelationTuple -> RelationTuple
101tupleExtend :: RelationTuple -> RelationTuple -> RelationTuple
71−tupleExtend (RelationTuple map1) (RelationTuple map2) = RelationTuple $ M.union map1 map2
102+tupleExtend (RelationTuple tupAttrs1 tupVec1) (RelationTuple tupAttrs2 tupVec2) = RelationTuple newAttrs newVec
103+ where
104+ newAttrs = tupAttrs1 V.++ tupAttrs2
105+ newVec = tupVec1 V.++ tupVec2
72
106
73{- sort the associative list to match the header sorting -}
107{- sort the associative list to match the header sorting -}
74tupleSortedAssocs :: RelationTuple -> [(AttributeName, Atom)]
108tupleSortedAssocs :: RelationTuple -> [(AttributeName, Atom)]
75−tupleSortedAssocs (RelationTuple tupMap) = L.sortBy (\x y -> compare (fst x) (fst y)) (M.assocs tupMap)
109+tupleSortedAssocs (RelationTuple tupAttrs tupVec) = V.toList $ V.map (\(index,attr) -> (attributeName attr, tupVec V.! index)) $ V.indexed tupAttrs
76−
110+
111+--this could be cheaper- it may not be wortwhile to update all the tuples for projection, but then the attribute management must be slightly different- perhaps the attributes should be a vector of association tuples [(name, index)]
112+tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple
113+tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec
114+ where
115+ deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) attrs
116+ indexDeleter = V.ifilter (\index _ -> V.notElem index deleteIndices)
117+ newAttrs = indexDeleter attrs
118+ newTupVec = indexDeleter tupVec
119+
120+--return the attributes and atoms which are equal in both vectors
121+--semi-join
122+tupleIntersection :: RelationTuple -> RelationTuple -> RelationTuple
123+tupleIntersection tuple1 tuple2 = RelationTuple newAttrs newTupVec
124+ where
125+ attrs1 = tupleAttributes tuple1
126+ attrs2 = tupleAttributes tuple2
127+ matchingIndices = V.findIndices (\attr -> V.elem attr attrs2 &&
128+ atomForAttributeName (attributeName attr) tuple1 ==
129+ atomForAttributeName (attributeName attr) tuple2
130+ ) attrs1
131+ indexFilter = V.ifilter (\index _ -> V.elem index matchingIndices)
132+ newAttrs = indexFilter attrs1
133+ newTupVec = indexFilter (tupleAtoms tuple1)
134+
135+updateTuple :: (M.Map AttributeName Atom) -> RelationTuple -> RelationTuple
136+updateTuple updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec
137+ where
138+ updateKeysSet = M.keysSet updateMap
139+ updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs)
140+ newVec = V.update tupVec updateVec
141+ updateVec = V.map (\(index, attr) -> (index, updateMap M.! (attributeName attr))) updateKeysIVec
142+
143+tupleToMap :: RelationTuple -> (M.Map AttributeName Atom)
144+tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList
145+ where
146+ assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed attrs)
147+
148+verifyTuple :: RelationTuple -> Either RelationalError RelationTuple
149+verifyTuple tuple = V.foldr (\attr acc ->
150+ case atomForAttributeName (attributeName attr) tuple of
151+ Left err -> Left err
152+ Right atom -> case atomTypeForAttributeName (attributeName attr) (tupleAttributes tuple) of
153+ Nothing -> Left $ NoSuchAttributeNameError (attributeName attr)
154+ Just expectedAtomType -> if atomTypeForAtom atom == expectedAtomType
155+ then
156+ acc
157+ else
158+ Left $ TupleAttributeTypeMismatchError (attributesFromList [attr])
159+ ) (Right tuple) (tupleAttributes tuple)
160+
161+
ProjectM36/TupleSet.hs+14−10
@@ -1,27 +1,31 @@
1module ProjectM36.TupleSet where
1module ProjectM36.TupleSet where
2import ProjectM36.Base
2import ProjectM36.Base
3import ProjectM36.Tuple
3import ProjectM36.Tuple
4−import ProjectM36.Attribute
5import ProjectM36.Error
4import ProjectM36.Error
6−import qualified Data.Map as M
7import qualified Data.HashSet as HS
5import qualified Data.HashSet as HS
8import Control.Monad
6import Control.Monad
7+import qualified Data.Vector as V
9
8
10emptyTupleSet :: RelationTupleSet
9emptyTupleSet :: RelationTupleSet
11emptyTupleSet = HS.empty
10emptyTupleSet = HS.empty
12
11
13−emptyAttributeSet :: Attributes
12+singletonTupleSet :: RelationTupleSet
14−emptyAttributeSet = M.empty
13+singletonTupleSet = HS.singleton emptyTuple
15
14
16--ensure that all maps have the same keys and key count
15--ensure that all maps have the same keys and key count
17
16
18−verifyRelationTupleSet :: Attributes -> RelationTupleSet -> Either RelationalError RelationTupleSet
17+verifyTupleSet :: Attributes -> RelationTupleSet -> Either RelationalError RelationTupleSet
19−verifyRelationTupleSet attrs tupleSet = do
18+verifyTupleSet attrs tupleSet = do
20 --check that all tuples have the same types
19 --check that all tuples have the same types
21 tupleList <- forM (HS.toList tupleSet) verifyTuple
20 tupleList <- forM (HS.toList tupleSet) verifyTuple
22 return $ HS.fromList tupleList
21 return $ HS.fromList tupleList
22+
23+mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTupleSet
24+mkTupleSet attrs tuples = verifyTupleSet attrs tupSet
23 where
25 where
24− verifyTuple tuple = if tupleAttributes tuple == attrs then
26+ tupSet = HS.fromList tuples
25− Right tuple
27+
26− else
28+mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet
27− Left $ TupleAttributeTypeMismatchError (attributesDifference (tupleAttributes tuple) attrs)
29+mkTupleSetFromList attrs atomMatrix = verifyTupleSet attrs tupSet
30+ where
31+ tupSet = HS.fromList $ map (\atomList -> mkRelationTuple attrs (V.fromList atomList)) atomMatrix
TutorialD/Interpreter.hs+13−11
@@ -5,11 +5,13 @@ import ProjectM36.Relation
5import ProjectM36.Tuple
5import ProjectM36.Tuple
6import ProjectM36.TupleSet
6import ProjectM36.TupleSet
7import ProjectM36.Error
7import ProjectM36.Error
8+import qualified ProjectM36.Attribute as A
8import ProjectM36.RelationalExpression
9import ProjectM36.RelationalExpression
9import ProjectM36.Relation.Show.Term
10import ProjectM36.Relation.Show.Term
10import ProjectM36.StaticOptimizer
11import ProjectM36.StaticOptimizer
11import ProjectM36.Transaction
12import ProjectM36.Transaction
12import ProjectM36.Transaction.Show
13import ProjectM36.Transaction.Show
14+import ProjectM36.Atom
13import Text.Parsec
15import Text.Parsec
14import Text.Parsec.String
16import Text.Parsec.String
15import Text.Parsec.Expr
17import Text.Parsec.Expr
@@ -26,6 +28,7 @@ import System.IO
26import System.Directory (getHomeDirectory)
28import System.Directory (getHomeDirectory)
27import qualified Data.UUID as U
29import qualified Data.UUID as U
28import Data.UUID.V4 (nextRandom)
30import Data.UUID.V4 (nextRandom)
31+import qualified Data.Vector as V
29
32
30{-
33{-
31List of Tutorial D operators:
34List of Tutorial D operators:
@@ -72,8 +75,8 @@ attributeList = sepBy identifier comma
72makeRelation :: Parser RelationalExpr
75makeRelation :: Parser RelationalExpr
73makeRelation = do
76makeRelation = do
74 reservedOp "relation"
77 reservedOp "relation"
75− attrs <- (try makeAttributes <|> return M.empty)
78+ attrs <- (try makeAttributes <|> return A.emptyAttributes)
76− if not (M.null attrs) then do
79+ if not (A.null attrs) then do
77 return $ MakeStaticRelation attrs emptyTupleSet
80 return $ MakeStaticRelation attrs emptyTupleSet
78 else do
81 else do
79 tuples <- braces (sepBy tupleP comma)
82 tuples <- braces (sepBy tupleP comma)
@@ -83,9 +86,7 @@ makeRelation = do
83makeAttributes :: Parser Attributes
86makeAttributes :: Parser Attributes
84makeAttributes = do
87makeAttributes = do
85 attrList <- braces (sepBy attributeAndType comma)
88 attrList <- braces (sepBy attributeAndType comma)
86− return $ M.fromList $ map toAttributeAssocList attrList
89+ return $ A.attributesFromList attrList
87− where
88− toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
89
90
90attributeAndType :: Parser Attribute
91attributeAndType :: Parser Attribute
91attributeAndType = do
92attributeAndType = do
@@ -99,8 +100,10 @@ attributeAndType = do
99tupleP :: Parser RelationTuple
100tupleP :: Parser RelationTuple
100tupleP = do
101tupleP = do
101 reservedOp "tuple"
102 reservedOp "tuple"
102− attrValues <- braces (sepBy tupleAtomP comma)
103+ attrAssocs <- braces (sepBy tupleAtomP comma)
103− return $ RelationTuple (M.fromList attrValues)
104+ let attrs = A.attributesFromList $ map (\(attrName, atom) -> Attribute attrName (atomTypeForAtom atom)) attrAssocs
105+ let atoms = V.fromList $ map snd attrAssocs
106+ return $ mkRelationTuple attrs atoms
104
107
105tupleAtomP :: Parser (AttributeName, Atom)
108tupleAtomP :: Parser (AttributeName, Atom)
106tupleAtomP = do
109tupleAtomP = do
@@ -375,8 +378,7 @@ showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribu
375 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
378 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
376 Just t -> show t
379 Just t -> show t
377 Nothing -> "unknown"
380 Nothing -> "unknown"
378− attrs = values (attributes rel)
381+ attrs = V.toList $ attributes rel
379− values m = map snd (M.toAscList m)
380
382
381data TutorialDOperatorResult = QuitResult |
383data TutorialDOperatorResult = QuitResult |
382 DisplayResult String |
384 DisplayResult String |
@@ -497,7 +499,7 @@ interpretNO context tutdstring = case parseString tutdstring of
497
499
498-- for interpreter-specific operations
500-- for interpreter-specific operations
499interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
501interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
500−interpretOps newUUID trans@(DisconnectedTransaction parentUUID context) transGraph instring = case parse interpreterOps "" instring of
502+interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
501 Left err -> (trans, transGraph, NoActionResult)
503 Left err -> (trans, transGraph, NoActionResult)
502 Right ops -> case ops of
504 Right ops -> case ops of
503 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
505 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
@@ -509,7 +511,7 @@ promptText :: DisconnectedTransaction -> TransactionGraph -> String
509promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "
511promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "
510 where
512 where
511 transInfo = case transactionForUUID parentUUID graph of
513 transInfo = case transactionForUUID parentUUID graph of
512− Left err -> "unknown"
514+ Left _ -> "unknown"
513 Right parentTrans -> case headNameForTransaction parentTrans graph of
515 Right parentTrans -> case headNameForTransaction parentTrans graph of
514 Nothing -> show $ transactionUUID parentTrans
516 Nothing -> show $ transactionUUID parentTrans
515 Just headName -> headName
517 Just headName -> headName
TutorialD/tutd.hs+1
@@ -4,6 +4,7 @@ import ProjectM36.Transaction
4import ProjectM36.Base
4import ProjectM36.Base
5import Data.UUID.V4 (nextRandom)
5import Data.UUID.V4 (nextRandom)
6
6
7+main :: IO ()
7main = do
8main = do
8 freshUUID <- nextRandom
9 freshUUID <- nextRandom
9 let currentHeadName = "master"
10 let currentHeadName = "master"
project-m36.cabal+1−1
@@ -7,7 +7,7 @@ Category: Relational Algebra
7Cabal-Version: >= 1.2
7Cabal-Version: >= 1.2
8
8
9Library
9Library
10− Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava,text,bytestring,deepseq,deepseq-generics
10+ Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava,text,bytestring,deepseq,deepseq-generics,vector
11 Exposed-Modules: ProjectM36.Error,
11 Exposed-Modules: ProjectM36.Error,
12 ProjectM36.Transaction,
12 ProjectM36.Transaction,
13 ProjectM36.Transaction.Show,
13 ProjectM36.Transaction.Show,
test/Relation/Basic.hs+33−30
@@ -3,28 +3,31 @@ import ProjectM36.Base
3import ProjectM36.Relation
3import ProjectM36.Relation
4import ProjectM36.Error
4import ProjectM36.Error
5import ProjectM36.Tuple
5import ProjectM36.Tuple
6−import ProjectM36.TupleSet
6+import ProjectM36.Atom
7−import qualified Data.Set as S
7+import qualified ProjectM36.Attribute as A
8−import qualified Data.Map as M
9import qualified Data.HashSet as HS
8import qualified Data.HashSet as HS
9+import qualified Data.Vector as V
10import System.Exit
10import System.Exit
11−import Control.Monad
12
11
12+testList :: Test
13−testList = TestList [testRelation relationTrue, testRelation relationFalse,
13+testList = TestList [testRelation "relationTrue" relationTrue, testRelation "relationFalse" relationFalse,
14+ testMkRelation1,
14 testRename1, testRename2]
15 testRename1, testRename2]
16+
17+main :: IO ()
15main = do
18main = do
16− counts <- runTestTT testList
19+ tcounts <- runTestTT testList
17− if errors counts + failures counts > 0 then exitFailure else exitSuccess
20+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
18
21
19−testRelation :: Relation -> Test
22+testRelation :: String -> Relation -> Test
20−testRelation rel = TestCase $ assertEqual "nope" relationValidation (Right rel)
23+testRelation testName rel = TestCase $ assertEqual testName relationValidation (Right rel)
21 where
24 where
22 relationValidation = validateRelation rel
25 relationValidation = validateRelation rel
23
26
24-- run common relation checks
27-- run common relation checks
25validateRelation :: Relation -> Either RelationalError Relation
28validateRelation :: Relation -> Either RelationalError Relation
26validateRelation rel = do
29validateRelation rel = do
27− validateAttrNamesMatchTupleAttrNames rel
30+ _ <- validateAttrNamesMatchTupleAttrNames rel
28 validateAttrTypesMatchTupleAttrTypes rel
31 validateAttrTypesMatchTupleAttrTypes rel
29
32
30validateAttrNamesMatchTupleAttrNames :: Relation -> Either RelationalError Relation
33validateAttrNamesMatchTupleAttrNames :: Relation -> Either RelationalError Relation
@@ -32,30 +35,30 @@ validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupMapSet)
32 | HS.null invalidSet = Right rel
35 | HS.null invalidSet = Right rel
33 | otherwise = Left $ AttributeNameMismatchError ""
36 | otherwise = Left $ AttributeNameMismatchError ""
34 where
37 where
35− nameCheck (RelationTuple tupMap) = attributeNames rel == M.keysSet tupMap
38+ nameCheck tuple = attributeNames rel == tupleAttributeNameSet tuple
36− relAttrNames = attributeNames rel
37 invalidSet = HS.filter (not . nameCheck) tupMapSet
39 invalidSet = HS.filter (not . nameCheck) tupMapSet
38
40
39−
40validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation
41validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation
41−validateAttrTypesMatchTupleAttrTypes rel@(Relation _ tupMapSet)
42+validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = HS.foldr (\tuple acc ->
42− | HS.null invalidSet = Right rel
43+ if (tupleAttributes tuple) == attrs && tupleAtomCheck tuple then
44+ acc
45+ else
43− | otherwise = Left (TupleAttributeTypeMismatchError M.empty) --fix to include invalid attrs
46+ Left $ TupleAttributeTypeMismatchError A.emptyAttributes
47+ ) (Right rel) tupSet
44 where
48 where
45− tupleTypeCheck (RelationTuple tupMap) = M.null $ M.filterWithKey attrTypeCheck tupMap
49+ tupleAtomCheck tuple = V.all (== True) (attrChecks tuple)
46− attrTypeCheck attrName atomValue = case attributeTypeForName attrName rel of
50+ attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of
47− Just t -> atomValueType atomValue == t
48− _ -> False
51+ Left _ -> False
49− invalidSet = HS.filter (not . tupleTypeCheck) tupMapSet
52+ Right atom -> (Just $ atomTypeForAtom atom) ==
53+ A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel)
50
54
55+simpleRel :: Relation
51simpleRel = case mkRelation attrs tupleSet of
56simpleRel = case mkRelation attrs tupleSet of
52 Right rel -> rel
57 Right rel -> rel
53− Left err -> undefined
58+ Left _ -> undefined
54 where
59 where
55− attrs = M.fromList [("a", Attribute "a" StringAtomType), ("b", Attribute "b" StringAtomType)]
60+ attrs = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" StringAtomType]
56− tupleSet = HS.fromList $ mkRelationTuples attrs [
57− M.fromList [("a", StringAtom "spam"), ("b", StringAtom "spam2")]
61+ tupleSet = HS.singleton $ mkRelationTuple attrs (V.fromList [StringAtom "spam", StringAtom "spam2"])
58− ]
59
62
60--rename tests
63--rename tests
61testRename1 :: Test
64testRename1 :: Test
@@ -67,8 +70,8 @@ testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRe
67--mkRelation tests
70--mkRelation tests
68--test tupleset key mismatch failure
71--test tupleset key mismatch failure
69testMkRelation1 :: Test
72testMkRelation1 :: Test
70−testMkRelation1 = TestCase $ assertEqual "key mismatch" (mkRelation testAttrs testTupSet) (Left $ AttributeCountMismatchError 0)
73+testMkRelation1 = TestCase $ assertEqual "key mismatch" (Left $ TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "a" StringAtomType])) (mkRelation testAttrs testTupSet)
71 where
74 where
72− testAttrs = M.singleton "a" (Attribute "a" StringAtomType)
75+ testAttrs = A.attributesFromList [Attribute "a" StringAtomType]
73− testTupSet = HS.fromList [(RelationTuple (M.singleton "a" $ StringAtom "v")),
76+ testTupSet = HS.fromList [mkRelationTuple testAttrs $ V.fromList [StringAtom "v"],
74− RelationTuple (M.singleton "a" $ IntAtom 2)]
77+ mkRelationTuple testAttrs $ V.fromList [IntAtom 2]]
test/Relation/StaticOptimizer.hs+6−7
@@ -6,20 +6,20 @@ import ProjectM36.StaticOptimizer
6import System.Exit
6import System.Exit
7import Control.Monad.State
7import Control.Monad.State
8import Test.HUnit
8import Test.HUnit
9−import qualified Data.Set as S
10
9
10+main :: IO ()
11main = do
11main = do
12− counts <- runTestTT (TestList tests)
12+ tcounts <- runTestTT (TestList tests)
13− if errors counts + failures counts > 0 then exitFailure else exitSuccess
13+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
14 where
14 where
15 tests = relationOptTests ++ databaseOptTests
15 tests = relationOptTests ++ databaseOptTests
16− optTest optfunc testparams = map (\(name, exp, unopt) -> TestCase $ assertEqual name exp (evalState (optfunc unopt) dateExamples)) $ testparams
16+ optTest optfunc testparams = map (\(name, expr, unopt) -> TestCase $ assertEqual name expr (evalState (optfunc unopt) dateExamples)) $ testparams
17 relationOptTests = optTest applyStaticRelationalOptimization [
17 relationOptTests = optTest applyStaticRelationalOptimization [
18− ("StaticProject", Right $ RelationVariable "S", Project (attributeNames s) (RelationVariable "S")),
18+ ("StaticProject", Right $ RelationVariable "S", Project (attributeNames suppliersRel) (RelationVariable "S")),
19 ("StaticUnion", Right $ RelationVariable "S", Union (RelationVariable "S") (RelationVariable "S")),
19 ("StaticUnion", Right $ RelationVariable "S", Union (RelationVariable "S") (RelationVariable "S")),
20 ("StaticJoin", Right $ RelationVariable "S", Join (RelationVariable "S") (RelationVariable "S")),
20 ("StaticJoin", Right $ RelationVariable "S", Join (RelationVariable "S") (RelationVariable "S")),
21 ("StaticRestrictTrue", Right $ RelationVariable "S", Restrict TruePredicate (RelationVariable "S")),
21 ("StaticRestrictTrue", Right $ RelationVariable "S", Restrict TruePredicate (RelationVariable "S")),
22− ("StaticRestrictFalse", Right $ MakeStaticRelation (attributes s) emptyTupleSet, Restrict (NotPredicate TruePredicate) (RelationVariable "S"))
22+ ("StaticRestrictFalse", Right $ MakeStaticRelation (attributes suppliersRel) emptyTupleSet, Restrict (NotPredicate TruePredicate) (RelationVariable "S"))
23 ]
23 ]
24 databaseOptTests = optTest applyStaticDatabaseOptimization [
24 databaseOptTests = optTest applyStaticDatabaseOptimization [
25 ("StaticAssign",
25 ("StaticAssign",
@@ -32,4 +32,3 @@ main = do
32 MultipleExpr [Assign "z" (Restrict TruePredicate (RelationVariable "S")),
32 MultipleExpr [Assign "z" (Restrict TruePredicate (RelationVariable "S")),
33 Assign "z" (Restrict TruePredicate (RelationVariable "S"))])
33 Assign "z" (Restrict TruePredicate (RelationVariable "S"))])
34 ]
34 ]
35− staticRelOptEqual name expected unoptimized = assertEqual name expected (evalState (applyStaticRelationalOptimization unoptimized) dateExamples)
test/TutorialD/Interpreter.hs+48−38
@@ -2,9 +2,12 @@ import TutorialD.Interpreter
2import Test.HUnit
2import Test.HUnit
3import ProjectM36.RelationalExpression
3import ProjectM36.RelationalExpression
4import ProjectM36.Relation
4import ProjectM36.Relation
5+import ProjectM36.Tuple
6+import ProjectM36.TupleSet
5import ProjectM36.Error
7import ProjectM36.Error
6import ProjectM36.Base
8import ProjectM36.Base
7import ProjectM36.Transaction
9import ProjectM36.Transaction
10+import qualified ProjectM36.Attribute as A
8import qualified Data.HashSet as HS
11import qualified Data.HashSet as HS
9import qualified Data.Map as M
12import qualified Data.Map as M
10import qualified Data.Set as S
13import qualified Data.Set as S
@@ -12,20 +15,22 @@ import System.Exit
12import Data.UUID.V4 (nextRandom)
15import Data.UUID.V4 (nextRandom)
13import Data.UUID (nil)
16import Data.UUID (nil)
14import Data.Either (isRight)
17import Data.Either (isRight)
18+import qualified Data.Vector as V
15
19
20+main :: IO ()
16main = do
21main = do
17− counts <- runTestTT (TestList tests)
22+ tcounts <- runTestTT (TestList tests)
18− if errors counts + failures counts > 0 then exitFailure else exitSuccess
23+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
19 where
24 where
20 tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest]
25 tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest]
21 simpleRelTests = [("x:=true", Right relationTrue),
26 simpleRelTests = [("x:=true", Right relationTrue),
22 ("x:=false", Right relationFalse),
27 ("x:=false", Right relationFalse),
23 ("x:=true union false", Right relationTrue),
28 ("x:=true union false", Right relationTrue),
24 ("x:=true; x:=false", Right relationFalse),
29 ("x:=true; x:=false", Right relationFalse),
25− ("x:=relation{a int}", mkRelation simpleAAttributes HS.empty),
30+ ("x:=relation{a int}", mkRelation simpleAAttributes emptyTupleSet),
26− ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes HS.empty),
31+ ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),
27− ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes HS.empty),
32+ ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),
28− ("x:=relation{tuple{a char(\"spam\"), b int(5)}}", mkRelation simpleCAttributes (HS.fromList $ map RelationTuple [M.fromList [("a", StringAtom "spam"),("b",IntAtom 5)]])),
33+ ("x:=relation{tuple{a char(\"spam\"), b int(5)}}", mkRelation simpleCAttributes $ HS.singleton ((RelationTuple simpleCAttributes) (V.fromList [StringAtom "spam", IntAtom 5]))),
29 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
34 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
30 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
35 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
31 ("x:=true where true", Right relationTrue),
36 ("x:=true where true", Right relationTrue),
@@ -37,20 +42,20 @@ main = do
37 ("x:=true=true", Right relationTrue),
42 ("x:=true=true", Right relationTrue),
38 ("x:=true=false", Right relationFalse),
43 ("x:=true=false", Right relationFalse),
39 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),
44 ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),
40− ("x:=relation {b int, a char}; insert x relation{tuple{b int(5), a char(\"spam\")}}", mkRelation simpleCAttributes (HS.fromList [RelationTuple $ M.fromList [("a", StringAtom "spam"), ("b", IntAtom 5)]])),
45+ ("x:=relation {b int, a char}; insert x relation{tuple{b int(5), a char(\"spam\")}}", mkRelation simpleCAttributes (HS.fromList [RelationTuple simpleCAttributes $ V.fromList [StringAtom "spam", IntAtom 5]])),
41− ("x:=relation{tuple{b int(5),a char(\"spam\")},tuple{b int(6),a char(\"sam\")}}; delete x where b=6", mkRelation simpleCAttributes $ HS.fromList [RelationTuple $ M.fromList [("a", StringAtom "spam"), ("b", IntAtom 5)]])
46+ ("x:=relation{tuple{b int(5),a char(\"spam\")},tuple{b int(6),a char(\"sam\")}}; delete x where b=6", mkRelation simpleCAttributes $ HS.singleton $ RelationTuple simpleCAttributes (V.fromList [StringAtom "spam", IntAtom 5]))
42 ]
47 ]
43− simpleAAttributes = M.fromList [("a", Attribute "a" IntAtomType)]
48+ simpleAAttributes = A.attributesFromList [Attribute "a" IntAtomType]
44− simpleBAttributes = M.fromList [("d", Attribute "d" IntAtomType)]
49+ simpleBAttributes = A.attributesFromList [Attribute "d" IntAtomType]
45− simpleCAttributes = M.fromList [("a", Attribute "a" StringAtomType), ("b", Attribute "b" IntAtomType)]
50+ simpleCAttributes = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" IntAtomType]
46− simpleProjectionAttributes = M.fromList [("c", Attribute "c" IntAtomType)]
51+ simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntAtomType]
47− dateExampleRelTests = [("x:=S where true", Right s),
52+ dateExampleRelTests = [("x:=S where true", Right suppliersRel),
48− ("x:=S where CITY = \"London\"", restrict (\(RelationTuple tupMap) -> tupMap M.! "CITY" == StringAtom "London") s),
53+ ("x:=S where CITY = \"London\"", restrict (\tuple -> atomForAttributeName "CITY" tuple == (Right $ StringAtom "London")) suppliersRel),
49− ("x:=S where false", Right $ Relation (attributes s) HS.empty),
54+ ("x:=S where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),
50− ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (M.fromList [("STATUS", Attribute "STATUS" IntAtomType)]) (HS.fromList [RelationTuple $ M.fromList [("STATUS", IntAtom 50)]])),
55+ ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (A.attributesFromList [ Attribute "STATUS" IntAtomType]) (HS.singleton $ mkRelationTuple (A.attributesFromList [Attribute "STATUS" IntAtomType]) (V.fromList [IntAtom 50]))),
51− ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\(RelationTuple tupMap) -> RelationTuple $ if tupMap M.! "SNAME" == StringAtom "Blake" then M.insert "CITY" (StringAtom "Boston") tupMap else tupMap) s)
56+ ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "SNAME" tuple == (Right $ StringAtom "Blake") then updateTuple (M.singleton "CITY" (StringAtom "Boston")) tuple else tuple) suppliersRel)
52 ]
57 ]
53−
58+assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion
54assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted
59assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted
55 where
60 where
56 interpreted = case interpret databaseContext tutd of
61 interpreted = case interpret databaseContext tutd of
@@ -59,47 +64,51 @@ assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interp
59 Nothing -> Left $ RelVarNotDefinedError "x"
64 Nothing -> Left $ RelVarNotDefinedError "x"
60 Just rel -> Right rel
65 Just rel -> Right rel
61
66
67+transactionGraphBasicTest :: Test
62transactionGraphBasicTest = TestCase $ do
68transactionGraphBasicTest = TestCase $ do
63− (discon, graph) <- dateExamplesGraph
69+ (_, graph) <- dateExamplesGraph
64 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
70 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
65
71
66--add a new transaction to the graph, validate it is in the graph
72--add a new transaction to the graph, validate it is in the graph
73+transactionGraphAddCommitTest :: Test
67transactionGraphAddCommitTest = TestCase $ do
74transactionGraphAddCommitTest = TestCase $ do
68− (discon@(DisconnectedTransaction firstUUID context), graph) <- dateExamplesGraph
75+ ((DisconnectedTransaction firstUUID context), origGraph) <- dateExamplesGraph
69 freshUUID <- nextRandom
76 freshUUID <- nextRandom
70 case interpret context "x:=S" of
77 case interpret context "x:=S" of
71− (Just err, newContext) -> assertFailure (show err)
78+ (Just err, _) -> assertFailure (show err)
72 (Nothing, newContext) -> do
79 (Nothing, newContext) -> do
73 let discon = newDisconnectedTransaction firstUUID newContext
80 let discon = newDisconnectedTransaction firstUUID newContext
74− let addTrans = addDisconnectedTransaction freshUUID "master" discon graph
81+ let addTrans = addDisconnectedTransaction freshUUID "master" discon origGraph
75 case addTrans of
82 case addTrans of
76 Left err -> assertFailure (show err)
83 Left err -> assertFailure (show err)
77 Right (newTrans, graph) -> do
84 Right (newTrans, graph) -> do
78 assertBool "transaction in graph" (isRight $ transactionForUUID freshUUID graph)
85 assertBool "transaction in graph" (isRight $ transactionForUUID freshUUID graph)
79 assertEqual "validate fresh commit with deleted S" (validateGraph graph) Nothing
86 assertEqual "validate fresh commit with deleted S" (validateGraph graph) Nothing
80− assertEqual "ensure S was deleted in newContext" (M.lookup "x" (relationVariables (transactionContext newTrans))) (Just s)
87+ assertEqual "ensure S was deleted in newContext" (M.lookup "x" (relationVariables (transactionContext newTrans))) (Just suppliersRel)
81
88
89+transactionRollbackTest :: Test
82transactionRollbackTest = TestCase $ do
90transactionRollbackTest = TestCase $ do
83− (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
91+ ((DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
84 freshUUID <- nextRandom
92 freshUUID <- nextRandom
85 case transactionForUUID firstUUID graph of
93 case transactionForUUID firstUUID graph of
86 Left err -> assertFailure (show err)
94 Left err -> assertFailure (show err)
87− Right firstTrans -> do
95+ Right _ -> do
88 case interpret origContext "x:=S" of
96 case interpret origContext "x:=S" of
89 (Just err, _) -> assertFailure (show err)
97 (Just err, _) -> assertFailure (show err)
90 (Nothing, newContext) -> do
98 (Nothing, newContext) -> do
91 let discon = newDisconnectedTransaction firstUUID newContext
99 let discon = newDisconnectedTransaction firstUUID newContext
92− let (updatedDiscon@(DisconnectedTransaction _ newContext2), newGraph, result) = interpretOps freshUUID discon graph ":rollback"
100+ let ((DisconnectedTransaction _ newContext2), newGraph, _) = interpretOps freshUUID discon graph ":rollback"
93 assertEqual "validate context" (M.lookup "x" (relationVariables newContext2)) Nothing
101 assertEqual "validate context" (M.lookup "x" (relationVariables newContext2)) Nothing
94 assertEqual "validate graph" graph newGraph
102 assertEqual "validate graph" graph newGraph
95
103
96--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
104--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
105+transactionJumpTest :: Test
97transactionJumpTest = TestCase $ do
106transactionJumpTest = TestCase $ do
98− (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
107+ ((DisconnectedTransaction firstUUID origContext), origGraph) <- dateExamplesGraph
99 freshUUID <- nextRandom
108 freshUUID <- nextRandom
100− case transactionForUUID firstUUID graph of
109+ case transactionForUUID firstUUID origGraph of
101 Left err -> assertFailure (show err)
110 Left err -> assertFailure (show err)
102− Right firstTrans -> do
111+ Right _ -> do
103 case interpret origContext "x:=S" of
112 case interpret origContext "x:=S" of
104 (Just err, _) -> assertFailure (show err)
113 (Just err, _) -> assertFailure (show err)
105 (Nothing, newContext) -> do
114 (Nothing, newContext) -> do
@@ -109,12 +118,12 @@ transactionJumpTest = TestCase $ do
109 (Nothing, newContext2) -> do
118 (Nothing, newContext2) -> do
110 --add the transaction
119 --add the transaction
111 let discon = newDisconnectedTransaction firstUUID newContext2
120 let discon = newDisconnectedTransaction firstUUID newContext2
112− let addTrans = addDisconnectedTransaction freshUUID "master" discon graph
121+ let addTrans = addDisconnectedTransaction freshUUID "master" discon origGraph
113 case addTrans of
122 case addTrans of
114 Left err -> assertFailure (show err)
123 Left err -> assertFailure (show err)
115− Right (newTrans, graph) -> do
124+ Right (_, graph) -> do
116 --jump to the first transaction
125 --jump to the first transaction
117− let (updatedDiscon@(DisconnectedTransaction parentUUID newContext3), newGraph, result) = interpretOps freshUUID discon graph (":jump " ++ show firstUUID)
126+ let ((DisconnectedTransaction parentUUID newContext3), newGraph, _) = interpretOps freshUUID discon graph (":jump " ++ show firstUUID)
118 assertEqual "validate discon" parentUUID firstUUID
127 assertEqual "validate discon" parentUUID firstUUID
119 assertEqual "validate discon2" Nothing (M.lookup "x" (relationVariables newContext3))
128 assertEqual "validate discon2" Nothing (M.lookup "x" (relationVariables newContext3))
120 assertEqual "validate graph" transactionUUIDs (S.map transactionUUID (transactionsForGraph newGraph))
129 assertEqual "validate graph" transactionUUIDs (S.map transactionUUID (transactionsForGraph newGraph))
@@ -122,21 +131,22 @@ transactionJumpTest = TestCase $ do
122 transactionUUIDs = S.fromList [firstUUID, freshUUID]
131 transactionUUIDs = S.fromList [firstUUID, freshUUID]
123
132
124--branch from the first transaction and verify that there are two heads
133--branch from the first transaction and verify that there are two heads
134+transactionBranchTest :: Test
125transactionBranchTest = TestCase $ do
135transactionBranchTest = TestCase $ do
126− (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
136+ (origDiscon@(DisconnectedTransaction firstUUID origContext), origGraph) <- dateExamplesGraph
127 freshUUID1 <- nextRandom
137 freshUUID1 <- nextRandom
128 freshUUID2 <- nextRandom
138 freshUUID2 <- nextRandom
129− case transactionForUUID firstUUID graph of
139+ case transactionForUUID firstUUID origGraph of
130 Left err -> assertFailure (show err)
140 Left err -> assertFailure (show err)
131− Right firstTrans -> do
141+ Right _ -> do
132 let disconMaster = newDisconnectedTransaction firstUUID origContext
142 let disconMaster = newDisconnectedTransaction firstUUID origContext
133− let addTransMaster = addDisconnectedTransaction freshUUID1 "master" disconMaster graph
143+ let addTransMaster = addDisconnectedTransaction freshUUID1 "master" disconMaster origGraph
134 --add a second transaction to the "master" branch
144 --add a second transaction to the "master" branch
135 case addTransMaster of
145 case addTransMaster of
136 Left err -> assertFailure (show err)
146 Left err -> assertFailure (show err)
137− Right (newTrans, graph) -> do
147+ Right (_, graph) -> do
138 --add a third transaction to the "test" branch
148 --add a third transaction to the "test" branch
139− let (updatedDiscon, newGraph, result) = interpretOps freshUUID2 origDiscon graph ":branch test"
149+ let (_, newGraph, _) = interpretOps freshUUID2 origDiscon graph ":branch test"
140 assertEqual "verify test head" freshUUID2 $ maybeTransUUID (transactionForHead "test" newGraph)
150 assertEqual "verify test head" freshUUID2 $ maybeTransUUID (transactionForHead "test" newGraph)
141 assertEqual "verify master head" freshUUID1 $ maybeTransUUID (transactionForHead "master" newGraph)
151 assertEqual "verify master head" freshUUID1 $ maybeTransUUID (transactionForHead "master" newGraph)
142 where
152 where