git.iko.soy/project-m36
on master help sign in
WIP vectorize Attributes and Tuples

all tests pass

commit03c23d91bc2cdf0da75ee3830c3df1dfe77e36b1 authorAgentM <agentm@themactionfaction.com> dateSat 2 May 2015, 23:35 (11 years ago) parenta6d14b7
17 files changed+550−389
compare with master
unifiedsplit
ProjectM36/Atom.hs+11−2 ProjectM36/Attribute.hs+92−15 ProjectM36/Base.hs+46−10 ProjectM36/Error.hs+1−1 ProjectM36/Relation.hs+61−130 ProjectM36/Relation/Show/CSV.hs+3−2 ProjectM36/Relation/Show/Term.hs+23−14 ProjectM36/RelationalExpression.hs+54−59 ProjectM36/Transaction/Show.hs+21−22 ProjectM36/Tuple.hs+122−37 ProjectM36/TupleSet.hs+14−10 TutorialD/Interpreter.hs+13−11 TutorialD/tutd.hs+1 project-m36.cabal+1−1 test/Relation/Basic.hs+33−30 test/Relation/StaticOptimizer.hs+6−7 test/TutorialD/Interpreter.hs+48−38
ProjectM36/Atom.hs+11−2
@@ -1,4 +1,13 @@
11module ProjectM36.Atom where
2−--import ProjectM36.Base
3−--import ProjectM36.Attribute
2+import ProjectM36.Base
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
413
ProjectM36/Attribute.hs+92−15
@@ -1,19 +1,90 @@
11module ProjectM36.Attribute where
22import ProjectM36.Base
3−import qualified Data.Map as M
3+import ProjectM36.Error
44import qualified Data.Set as S
55import 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)
656
757renameAttribute :: AttributeName -> Attribute -> Attribute
858renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo
959
10−remapWithAttributes :: S.Set AttributeName -> M.Map AttributeName Atom -> M.Map AttributeName Atom
11−remapWithAttributes attrs m = M.intersection m hollowMap
60+renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes
61+renameAttributes oldAttrName newAttrName attrs = V.map renamer attrs
1262 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
1477
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+
1586attributeNameSet :: Attributes -> S.Set AttributeName
16−attributeNameSet = M.keysSet
87+attributeNameSet attrVec = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) attrVec
1788
1889--checks if set s1 is wholly contained in the set s2
1990attributesContained :: Attributes -> Attributes -> Bool
@@ -35,14 +106,20 @@ sortedAttributeNameList :: S.Set AttributeName -> [AttributeName]
35106sortedAttributeNameList attrNameSet= L.sort $ S.toList attrNameSet
36107
37108-- take two attribute sets and return an attribute set with the attributes which do not match
38−-- bug: missing attributes don't show up (?)
39−attributesDifference :: Attributes -> Attributes -> Attributes
40−attributesDifference attrA attrB = M.union mismatchA missingB
41− where
42− mismatchA = M.foldrWithKey folder M.empty attrA
43− missingB = M.difference attrA attrB
44− folder :: AttributeName -> Attribute -> Attributes -> Attributes
45− folder attrName attrinA acc = if M.notMember attrName attrB || M.lookup attrName attrB /= Just attrinA then
46− M.insert attrName attrinA acc
109+attributesDifference :: Attributes -> Attributes -> Attributes
110+attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)
111+ where
112+ diff a b = (a L.\\ b) ++ (b L.\\ a)
113+
114+vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a
115+vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn
116+
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)
47121 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)
99import Control.DeepSeq (NFData, rnf)
1010import Control.DeepSeq.Generics (genericRnf)
1111import GHC.Generics (Generic)
12+import qualified Data.Vector as V
13+import qualified Data.List as L
1214
1315data Atom = StringAtom String |
1416 IntAtom Int |
1517 RelationAtom Relation deriving (Show, Eq, Generic)
1618
17−instance NFData Atom where rnf = genericRnf
19+instance NFData Atom where rnf = genericRnf
20+
21+instance Hash.Hashable Atom
1822
1923data AtomType = StringAtomType |
2024 IntAtomType |
2125 RelationAtomType Attributes deriving (Eq, Show, Generic)
2226
2327instance 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
2928
3029type AttributeName = String
3130type AtomName = String
3231
3332data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)
3433
34+instance Hash.Hashable Attribute where
35+ hashWithSalt salt (Attribute attrName _) = Hash.hashWithSalt salt attrName
36+
3537instance NFData Attribute where rnf = genericRnf
3638
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)
3848
3949type RelationTupleSet = HS.HashSet RelationTuple
4050
51+--the same hash must be generated for equal tuples so that the hashset equality works
4152instance 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
4360
44−data RelationTuple = RelationTuple (M.Map AttributeName Atom) deriving (Eq, Show, Generic)
61+--maybe the attribute->int mapping should be stored once in the relation and then passed down when needed
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
4571
4672instance NFData RelationTuple where rnf = genericRnf
4773
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
4978
5079instance 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)
5187
5288data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic)
5389data RelationSizeInfinite = RelationSizeInfinite
ProjectM36/Error.hs+1−1
@@ -2,7 +2,7 @@ module ProjectM36.Error where
22import ProjectM36.Base
33import qualified Data.UUID as U
44
5−data RelationalError = NoSuchAttributeNameError String
5+data RelationalError = NoSuchAttributeNameError AttributeName
66 | TupleAttributeCountMismatchError Int --attribute name
77 | TupleAttributeTypeMismatchError Attributes
88 | AttributeCountMismatchError Int
ProjectM36/Relation.hs+61−130
@@ -1,14 +1,14 @@
11-- this is an implementation of the Relation typeclass which creates a GADT DSL
22{-# LANGUAGE GADTs,ExistentialQuantification,NoImplicitPrelude #-}
33module ProjectM36.Relation where
4−import qualified Data.Map as M
54import qualified Data.Set as S
65import qualified Data.HashSet as HS
76import Control.Monad
7+import qualified Data.Vector as V
88
99import ProjectM36.Base
1010import ProjectM36.Tuple
11−import ProjectM36.Attribute
11+import qualified ProjectM36.Attribute as A
1212import ProjectM36.TupleSet
1313import ProjectM36.Error
1414import Prelude hiding (join)
@@ -17,48 +17,48 @@ attributes :: Relation -> Attributes
1717attributes (Relation attrs _ ) = attrs
1818
1919attributeNames :: Relation -> S.Set AttributeName
20−attributeNames (Relation attrs _) = M.keysSet attrs
20+attributeNames (Relation attrs _) = A.attributeNameSet attrs
2121
2222attributeForName :: AttributeName -> Relation -> Maybe Attribute
23−attributeForName attrName (Relation attrs _) = M.lookup attrName attrs
23+attributeForName attrName (Relation attrs _) = A.attributeForName attrName attrs
2424
2525attributesForNames :: S.Set AttributeName -> Relation -> Attributes
26−attributesForNames attrNameSet (Relation attrs _) = M.intersection attrs hollowMap
27− where
28− hollowMap = M.fromList $ zip (S.toList attrNameSet) (repeat (Attribute "" StringAtomType))
26+attributesForNames attrNameSet (Relation attrs _) = A.attributesForNames attrNameSet attrs
2927
30−attributeTypeForName :: AttributeName -> Relation -> Maybe AtomType
31−attributeTypeForName attrName rel = case attr of
32− (Just (Attribute _ atomType)) -> Just atomType
33− _ -> Nothing
34− where
35− attr = attributeForName attrName rel
28+atomTypeForName :: AttributeName -> Relation -> Maybe AtomType
29+atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs
3630
3731atomValueType :: Atom -> AtomType
3832atomValueType (StringAtom _) = StringAtomType
3933atomValueType (IntAtom _) = IntAtomType
4034atomValueType (RelationAtom rel) = RelationAtomType (attributes rel)
4135
36+mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation
37+mkRelationFromList attrs atomMatrix = do
38+ tupSet <- mkTupleSetFromList attrs atomMatrix
39+ return $ Relation attrs tupSet
40+
4241mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation
4342mkRelation attrs tupleSet = do
4443 --check that all tuples have the same keys
4544 --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
4746 Left err -> Left err
4847 Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet
4948
5049relationTrue :: Relation
51−relationTrue = Relation M.empty $ HS.singleton (RelationTuple M.empty)
50+relationTrue = Relation A.emptyAttributes singletonTupleSet
5251
5352relationFalse :: Relation
54−relationFalse = Relation M.empty emptyTupleSet
53+relationFalse = Relation A.emptyAttributes emptyTupleSet
5554
5655madeTrue :: Either RelationalError Relation
57−madeTrue = mkRelation M.empty (HS.fromList [])
56+madeTrue = mkRelation A.emptyAttributes (HS.fromList [])
5857
5958madeFalse :: Either RelationalError Relation
60−madeFalse = mkRelation M.empty emptyTupleSet
59+madeFalse = mkRelation A.emptyAttributes emptyTupleSet
6160
61+{-
6262--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
6363singletonValueFromRelation :: Relation -> Either RelationalError Atom
6464singletonValueFromRelation rel@(Relation _ tupSet) = if cardinality rel /= Countable 1 then
@@ -71,6 +71,7 @@ singletonValueFromRelation rel@(Relation _ tupSet) = if cardinality rel /= Count
7171 value = snd $ head $ M.toList tupMap
7272 tupMap = tup2Map $ head (HS.toList tupSet)
7373 tup2Map (RelationTuple tupmap) = tupmap
74+-}
7475
7576union :: Relation -> Relation -> Either RelationalError Relation
7677union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
@@ -83,7 +84,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =
8384
8485project :: S.Set AttributeName -> Relation -> Either RelationalError Relation
8586project projectionAttrNames rel =
86− if not $ attributeNamesContained projectionAttrNames (attributeNames rel)
87+ if not $ A.attributeNamesContained projectionAttrNames (attributeNames rel)
8788 then Left $ AttributeNameMismatchError ""
8889 else
8990 relFold folder (Right $ Relation newAttrs HS.empty) rel
@@ -94,12 +95,6 @@ project projectionAttrNames rel =
9495 Left err -> Left err
9596 Right acc2 -> union acc2 (Relation newAttrs (HS.singleton (tupleProject projectionAttrNames tupleToProject)))
9697
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
10398rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation
10499rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =
105100 if not attributeValid
@@ -109,15 +104,15 @@ rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =
109104 else
110105 mkRelation newAttrs newTupSet
111106 where
112− newAttributeInUse = attributeNamesContained (S.singleton newAttrName) (attributeNames rel)
113− attributeValid = attributeNamesContained (S.singleton oldAttrName) (attributeNames rel)
114− newAttrs = M.delete oldAttrName $ M.insert newAttrName (renameAttribute newAttrName (oldAttrs M.! oldAttrName)) oldAttrs
107+ newAttributeInUse = A.attributeNamesContained (S.singleton newAttrName) (attributeNames rel)
108+ attributeValid = A.attributeNamesContained (S.singleton oldAttrName) (attributeNames rel)
109+ newAttrs = A.renameAttributes oldAttrName newAttrName oldAttrs
115110 newTupSet = HS.map tupsetmapper oldTupSet
116111 tupsetmapper tuple = tupleRenameAttribute oldAttrName newAttrName tuple
117112
118113--the algebra should return a relation of one attribute and one row with the arity
119114arity :: Relation -> Int
120−arity (Relation attrs _) = M.size attrs
115+arity (Relation attrs _) = A.arity attrs
121116
122117cardinality :: Relation -> RelationCardinality
123118cardinality (Relation _ tupSet) = Countable (HS.size tupSet)
@@ -151,31 +146,33 @@ group groupAttrNames newAttrName rel = do
151146 nonGroupProjection <- project nonGroupAttrNames rel
152147 relFold folder (Right $ Relation newAttrs emptyTupleSet) nonGroupProjection
153148 where
154− newAttrs = M.insert newAttrName groupAttr (attributesForNames nonGroupAttrNames rel)
149+ newAttrs = A.addAttribute groupAttr (attributesForNames nonGroupAttrNames rel)
155150 groupAttr = Attribute newAttrName (RelationAtomType (attributesForNames nonGroupAttrNames rel))
156− nonGroupAttrNames = nonMatchingAttributeNameSet groupAttrNames (attributeNames rel)
151+ nonGroupAttrNames = A.nonMatchingAttributeNameSet groupAttrNames (attributeNames rel)
157152 folder tupleIn acc = case acc of
158153 Left err -> Left err
159154 Right acc2 -> union acc2 (Relation newAttrs (HS.singleton (tupleExtend tupleIn (matchingRelTuple tupleIn))))
160155 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))
162157 Left _ -> undefined
163158
164159--help restriction function
165160--returns a subrelation of
166161restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation
167−restrictEq (RelationTuple tupMap) rel = restrict rfilter rel
162+restrictEq tuple rel = restrict rfilter rel
168163 where
169164 rfilter :: RelationTuple -> Bool
170− rfilter (RelationTuple tupMap2) = M.isSubmapOf tupMap tupMap2
165+ rfilter tupleIn = tupleIntersection tuple tupleIn /= emptyTuple
171166
172167-- unwrap relation-valued attribute
173168-- return error if relval attrs and nongroup attrs overlap
174169ungroup :: AttributeName -> Relation -> Either RelationalError Relation
175−ungroup relvalAttrName rel = relFold relFolder (Right $ Relation newAttrs emptyTupleSet) rel
176− where
177− newAttrs = M.union (attributesForRelval relvalAttrName rel) nonGroupAttrs
178− nonGroupAttrs = M.delete relvalAttrName (attributes rel)
170+ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of
171+ Left err -> Left err
172+ Right relvalAttrs -> relFold relFolder (Right $ Relation newAttrs emptyTupleSet) rel
173+ where
174+ newAttrs = A.addAttributes relvalAttrs nonGroupAttrs
175+ nonGroupAttrs = A.deleteAttributeName relvalAttrName (attributes rel)
179176 relFolder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation
180177 relFolder tupleIn acc = case (tupleUngroup relvalAttrName newAttrs tupleIn) of
181178 Right ungroupRelation -> case acc of
@@ -187,36 +184,20 @@ ungroup relvalAttrName rel = relFold relFolder (Right $ Relation newAttrs emptyT
187184
188185--take an relval attribute name and a tuple and ungroup the relval
189186tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation
190−tupleUngroup relvalAttrName newAttrs tuple@(RelationTuple tupMap) = case (tupMap M.! relvalAttrName) of
191− (RelationAtom relvalRelation) -> 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
187+tupleUngroup relvalAttrName newAttrs tuple = do
188+ relvalRelation <- relationForAttributeName relvalAttrName tuple
189+ relFold folder (Right $ Relation newAttrs emptyTupleSet) relvalRelation
209190 where
210− --this is only temporarily needed until the Relation stores the types of the columns as data- hack alert
211− --find a tuple with attributes to steal to ungroup
212− oneTuple :: RelationTupleSet -> RelationTuple
213− oneTuple tupSet = head $ HS.toList $ HS.filter (\(RelationTuple tupMap) -> M.size tupMap > 0) tupSet
214− relvalRelation = unsafeRelValFromAtom $ tupleAtomForAttribute (oneTuple tupleSet) relvalAttrName
215− where
216− unsafeRelValFromAtom :: Atom -> Relation
217− unsafeRelValFromAtom (RelationAtom rel) = rel
218− unsafeRelValFromAtom (StringAtom _) = undefined
219− unsafeRelValFromAtom (IntAtom _) = undefined
191+ nonGroupTupleProjection = tupleProject nonGroupAttrNames tuple
192+ nonGroupAttrNames = A.attributeNameSet newAttrs
193+ folder tupleIn acc = case acc of
194+ Left err -> Left err
195+ Right accRel -> union accRel $ Relation newAttrs (HS.singleton (tupleExtend nonGroupTupleProjection tupleIn))
196+
197+attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes
198+attributesForRelval relvalAttrName (Relation attrs _) = case A.atomTypeForAttributeName relvalAttrName attrs of
199+ (Just (RelationAtomType relAttrs)) -> Right relAttrs
200+ _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName
220201
221202restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation
222203restrict 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
225206--after changing from string atoms, there needs to be a type-checking step!
226207--this is a "nested loop" scan as described by the postgresql documentation
227208join :: Relation -> Relation -> Either RelationalError Relation
228−join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = Right $ Relation newAttrs newTupSet
229− where
230− newAttrs = M.union attrs1 attrs2
231− newTupSet = HS.foldr tupleSetJoiner emptyTupleSet tupSet1
232− tupleSetJoiner tuple1 accumulator = HS.union (singleTupleSetJoin tuple1 tupSet2) accumulator
209+join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = do
210+ let newTupSet = HS.foldr tupleSetJoiner emptyTupleSet tupSet1
211+ tupleSetJoiner tuple1 accumulator = HS.union (singleTupleSetJoin tuple1 tupSet2) accumulator
212+ newAttrs <- A.joinAttributes attrs1 attrs2
213+ return $ Relation newAttrs newTupSet
233214
234215--a map should NOT change the structure of a relation, so attributes should be constant
235216relMap :: (RelationTuple -> RelationTuple) -> Relation -> Either RelationalError Relation
@@ -242,7 +223,7 @@ relMap mapper (Relation attrs tupleSet) = do
242223 let remappedTuple = mapper tupleIn
243224 if tupleAttributes remappedTuple == tupleAttributes tupleIn
244225 then Right remappedTuple
245− else Left $ TupleAttributeTypeMismatchError (attributesDifference (tupleAttributes tupleIn) attrs)
226+ else Left $ TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs)
246227
247228--in the future, the mapper should be able to return a RelationalError likely
248229relMogrify :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation
@@ -258,12 +239,8 @@ relFold folder acc (Relation _ tupleSet) = HS.foldr folder acc tupleSet
258239imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation
259240imageRelationFor matchTuple rel = do
260241 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
262243
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")])
267244
268245--returns a relation-valued attribute image relation for each tuple in rel1
269246--algorithm:
@@ -278,61 +255,15 @@ imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSe
278255 tupleSetJoiner tup1 acc = undefined
279256-}
280257
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−
328258-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long
329259-- this is useful for performance and resource usage testing
330260matrixRelation :: Int -> Int -> Either RelationalError Relation
331−matrixRelation attributeCount tupleCount = mkRelation attributeSet tupleSet
332− where
333− attributeSet = M.fromList $ map (\c-> (show c, Attribute (show c) IntAtomType)) [0 .. attributeCount]
334− tupleSet = HS.fromList $ mkRelationTuples attributeSet $ map (\c -> tuple c) [0 .. tupleCount]
335− tuple tupleX = M.fromList $ map (\c -> (show c, IntAtom tupleX)) [0..attributeCount]
261+matrixRelation attributeCount tupleCount = do
262+ let attrs = A.attributesFromList $ map (\c-> Attribute (show c) IntAtomType) [0 .. attributeCount]
263+ tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX))
264+ tupleSet <- mkTupleSet attrs $ map (\c -> tuple c) [0 .. tupleCount]
265+ mkRelation attrs tupleSet
266+
336267
337268
338269
ProjectM36/Relation/Show/CSV.hs+3−2
@@ -1,9 +1,10 @@
11module ProjectM36.Relation.Show.CSV where
22import ProjectM36.Base
33import Data.Csv
4−import qualified Data.Map as M
4+import ProjectM36.Tuple
55import qualified Data.HashSet as HS
66import qualified Data.ByteString.Lazy as BS
7+import qualified Data.Vector as V
78
89--maybe support a header in the future
910relationAsCSV :: Relation -> BS.ByteString
@@ -13,7 +14,7 @@ tupleSetAsCSV :: RelationTupleSet -> BS.ByteString
1314tupleSetAsCSV tupleSet = encode $ HS.toList tupleSet
1415
1516instance ToRecord RelationTuple where
16− toRecord (RelationTuple tupMap) = toRecord $ map toField (M.elems tupMap)
17+ toRecord tuple = toRecord $ map toField (V.toList $ tupleAtoms tuple)
1718
1819instance ToField Atom where
1920 toField (StringAtom atom) = toField atom
ProjectM36/Relation/Show/Term.hs+23−14
@@ -4,27 +4,40 @@ import ProjectM36.Base
44import ProjectM36.Tuple
55import ProjectM36.Relation
66import qualified Data.Set as S
7−import qualified Data.Map as M
87import qualified Data.HashSet as HS
98import qualified Data.List as L
109
10+boxV :: String
1111boxV = "│"
12+boxH :: String
1213boxH = "─"
1314
15+boxTL :: String
1416boxTL = "┌"
17+boxTR :: String
1518boxTR = "┐"
19+boxBL :: String
1620boxBL = "└"
21+boxBR :: String
1722boxBR = "┘"
1823
24+boxLB :: String
1925boxLB = "├"
26+boxRB :: String
2027boxRB = "┤"
28+boxTB :: String
2129boxTB = "┬"
30+boxBB :: String
2231boxBB = "┴"
2332
33+boxC :: String
2434boxC = "┼"
2535
36+dboxH :: String
2637dboxH = "═"
38+dboxL :: String
2739dboxL = "╞"
40+dboxR :: String
2841dboxR = "╡"
2942
3043class TermSize a where
@@ -40,14 +53,14 @@ addRow cells (header,body) = (header, body ++ [cells])
4053--calculate maximum per-row and per-column sizes
4154
4255cellLocations :: Table -> ([Int],[Int]) --column size, row size
43−cellLocations tab@(header, body) = (maxWidths, maxHeights)
56+cellLocations tab@(header, _) = (maxWidths, maxHeights)
4457 where
4558 cellSizeMatrix = cellSizes tab
4659 maxWidths = foldl mergeMax (baseSize (length header)) (map fst cellSizeMatrix)
4760 baseSize num = take num (repeat 0)
4861 rowHeights = map snd cellSizeMatrix
4962 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)
5164
5265--the normal "lines" function returns an empty list for an empty string which is not what we want
5366breakLines :: String -> [String]
@@ -67,7 +80,10 @@ relationAsTable rel@(Relation _ tupleSet) = (header, body)
6780 header = oAttrs
6881 body :: [[Cell]]
6982 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]
7187
7288showAtom :: Atom -> String
7389showAtom (StringAtom atom) = atom
@@ -93,7 +109,7 @@ renderHBar left middle end columnLocations = left ++ concat (L.intersperse middl
93109leftPaddedString :: Int -> Int -> String -> String
94110leftPaddedString lineNum size str = paddedLines !! lineNum
95111 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 "")
97113
98114renderRow :: [Cell] -> [Int] -> Int -> String -> String
99115renderRow cells columnLocations rowHeight interspersed = unlines $ map renderOneLine [0..rowHeight-1]
@@ -122,14 +138,7 @@ showRelation rel
122138 | otherwise = renderTable (relationAsTable rel)
123139
124140
141+{-
125142groupedExample :: Relation
126143groupedExample = case group (S.fromList ["CITY"]) "CITYREL" s of {Right rel -> rel}
127−
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−
144+-}
ProjectM36/RelationalExpression.hs+54−59
@@ -4,6 +4,7 @@ import ProjectM36.Tuple
44import ProjectM36.TupleSet
55import ProjectM36.Base
66import ProjectM36.Error
7+import qualified ProjectM36.Attribute as A
78import qualified Data.Map as M
89import qualified Data.HashSet as HS
910import Control.Monad.State hiding (join)
@@ -101,69 +102,65 @@ dateExamples = DatabaseContext { inclusionDependencies = HS.empty, -- add foreig
101102 suppliers = suppliersRel
102103 products = productsRel
103104 supplierProducts = supplierProductsRel
104−
105−suppliersRel :: Relation
106−suppliersRel = case mkRelation attributeSet tupleSet of
105+
106+suppliersRel :: Relation
107+suppliersRel = case mkRelationFromList attrs atomMatrix of
107108 Left _ -> undefined
108109 Right rel -> rel
109110 where
110− attributeSet = M.fromList [("S#", Attribute "S#" StringAtomType),
111− ("SNAME", Attribute "SNAME" StringAtomType),
112− ("STATUS", Attribute "STATUS" IntAtomType),
113− ("CITY", Attribute "CITY" StringAtomType)]
114− tupleSet = HS.fromList $ mkRelationTuples attributeSet [
115− M.fromList [("S#", StringAtom "S1") , ("SNAME", StringAtom "Smith"), ("STATUS", IntAtom 20) , ("CITY", StringAtom "London")],
116− M.fromList [("S#", StringAtom "S2"), ("SNAME", StringAtom "Jones"), ("STATUS", IntAtom 10), ("CITY", StringAtom "Paris")],
117− M.fromList [("S#", StringAtom "S3"), ("SNAME", StringAtom "Blake"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Paris")],
118− M.fromList [("S#", StringAtom "S4"), ("SNAME", StringAtom "Clark"), ("STATUS", IntAtom 20), ("CITY", StringAtom "London")],
119− M.fromList [("S#", StringAtom "S5"), ("SNAME", StringAtom "Adams"), ("STATUS", IntAtom 30), ("CITY", StringAtom "Athens")]]
120−
121−productsRel :: Relation
122−productsRel = case mkRelation attributeSet tupleSet of
111+ attrs = A.attributesFromList [Attribute "S#" StringAtomType,
112+ Attribute "SNAME" StringAtomType,
113+ Attribute "STATUS" IntAtomType,
114+ Attribute "CITY" StringAtomType]
115+ atomMatrix = [
116+ [StringAtom "S1", StringAtom "Smith", IntAtom 20, StringAtom "London"],
117+ [StringAtom "S2", StringAtom "Jones", IntAtom 10, StringAtom "Paris"],
118+ [StringAtom "S3", StringAtom "Blake", IntAtom 30, StringAtom "Paris"],
119+ [StringAtom "S4", StringAtom "Clark", IntAtom 20, StringAtom "London"],
120+ [StringAtom "S5", StringAtom "Adams", IntAtom 30, StringAtom "Athens"]]
121+
122+supplierProductsRel :: Relation
123+supplierProductsRel = case mkRelationFromList attrs matrix of
123124 Left _ -> undefined
124125 Right rel -> rel
125126 where
126− attributeSet = M.fromList [("P#", Attribute "P#" StringAtomType),
127− ("PNAME", Attribute "PNAME" StringAtomType),
128− ("COLOR", Attribute "COLOR" StringAtomType),
129− ("WEIGHT", Attribute "WEIGHT" IntAtomType),
130− ("CITY", Attribute "CITY" StringAtomType)]
131− tupleSet = HS.fromList $ mkRelationTuples attributeSet [
132− M.fromList [("P#", StringAtom "P1"), ("PNAME", StringAtom "Nut"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 12), ("CITY", StringAtom "London")],
133− M.fromList [("P#", StringAtom "P2"), ("PNAME", StringAtom "Bolt"), ("COLOR", StringAtom "Green"), ("WEIGHT", IntAtom 17), ("CITY", StringAtom "Paris")],
134− M.fromList [("P#", StringAtom "P3"), ("PNAME", StringAtom "Screw"), ("COLOR", StringAtom "Blue"), ("WEIGHT", IntAtom 17), ("CITY", StringAtom "Oslo")],
135− M.fromList [("P#", StringAtom "P4"), ("PNAME", StringAtom "Screw"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 14), ("CITY", StringAtom "London")],
136− M.fromList [("P#", StringAtom "P5"), ("PNAME", StringAtom "Cam"), ("COLOR", StringAtom "Blue"), ("WEIGHT", IntAtom 12), ("CITY", StringAtom "Paris")],
137− M.fromList [("P#", StringAtom "P6"), ("PNAME", StringAtom "Cog"), ("COLOR", StringAtom "Red"), ("WEIGHT", IntAtom 19), ("CITY", StringAtom "London")]
138−
127+ attrs = A.attributesFromList [Attribute "S#" StringAtomType,
128+ Attribute "P#" StringAtomType,
129+ Attribute "QTY" StringAtomType]
130+ matrix = [
131+ [StringAtom "S1", StringAtom "P1", IntAtom 300],
132+ [StringAtom "S1", StringAtom "P2", IntAtom 200],
133+ [StringAtom "S1", StringAtom "P3", IntAtom 400],
134+ [StringAtom "S1", StringAtom "P4", IntAtom 200],
135+ [StringAtom "S1", StringAtom "P5", IntAtom 100],
136+ [StringAtom "S1", StringAtom "P6", IntAtom 100],
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]
139143 ]
140−
141−supplierProductsRel :: Relation
142−supplierProductsRel = case mkRelation attributeSet tupleSet of
144+
145+productsRel :: Relation
146+productsRel = case mkRelationFromList attrs matrix of
143147 Left _ -> undefined
144148 Right rel -> rel
145149 where
146− attributeSet = M.fromList [("S#", Attribute "S#" StringAtomType),
147− ("P#", Attribute "P#" StringAtomType),
148− ("QTY", Attribute "QTY" IntAtomType)]
149− tupleSet = HS.fromList $ mkRelationTuples attributeSet [
150− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P1"), ("QTY", IntAtom 300)],
151− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P2"), ("QTY", IntAtom 200)],
152− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P3"), ("QTY", IntAtom 400)],
153− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P4"), ("QTY", IntAtom 200)],
154− M.fromList [("S#", StringAtom "S1"), ("P#", StringAtom "P5"), ("QTY", IntAtom 100)],
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)],
158− M.fromList [("S#", StringAtom "S2"), ("P#", StringAtom "P2"), ("QTY", IntAtom 400)],
159−
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−
150+ attrs = A.attributesFromList [Attribute "P#" StringAtomType,
151+ Attribute "PNAME" StringAtomType,
152+ Attribute "COLOR" StringAtomType,
153+ Attribute "WEIGHT" StringAtomType,
154+ Attribute "CITY" StringAtomType]
155+ matrix = [
156+ [StringAtom "P1", StringAtom "Nut", StringAtom "Red", IntAtom 12, StringAtom "London"],
157+ [StringAtom "P2", StringAtom "Bolt", StringAtom "Green", IntAtom 17, StringAtom "Paris"],
158+ [StringAtom "P3", StringAtom "Screw", StringAtom "Blue", IntAtom 17, StringAtom "Oslo"],
159+ [StringAtom "P4", StringAtom "Screw", StringAtom "Red", IntAtom 14, StringAtom "London"],
160+ [StringAtom "P5", StringAtom "Cam", StringAtom "Blue", IntAtom 12, StringAtom "Paris"],
161+ [StringAtom "P6", StringAtom "Cog", StringAtom "Red", IntAtom 19, StringAtom "London"]
162+ ]
163+
167164--helper function to process relation variable creation/assignment
168165setRelVar :: String -> Relation -> DatabaseState (Maybe RelationalError)
169166setRelVar relVarName rel = do
@@ -234,10 +231,8 @@ evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = d
234231 makeUpdatedRel relin = do
235232 restrictedPortion <- restrict predicateFunc relin
236233 unrestrictedPortion <- restrict (not . predicateFunc) relin
237− updatedPortion <- relMap tupleUpdater restrictedPortion
234+ updatedPortion <- relMap (updateTuple attrAssignments) restrictedPortion
238235 union updatedPortion unrestrictedPortion
239− tupleUpdater = \(RelationTuple tupMap) -> RelationTuple $ M.union attrAssignments tupMap
240−
241236
242237evalContextExpr (AddInclusionDependency dep) = do
243238 currstate <- get
@@ -333,9 +328,9 @@ predicateRestrictionFilter context (RelationalExprPredicate relExpr) = case runS
333328 else
334329 Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"
335330
336−predicateRestrictionFilter _ (AttributeEqualityPredicate attrName atom) = Right $ \(RelationTuple tupMap) -> tupValue tupMap == atom
337− where
338− tupValue tupMap = tupMap M.! attrName
331+predicateRestrictionFilter _ (AttributeEqualityPredicate attrName atom) = Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of
332+ Left _ -> False
333+ Right atom2 -> atom2 == atom
339334
340335
341336
ProjectM36/Transaction/Show.hs+21−22
@@ -5,9 +5,10 @@ import ProjectM36.Tuple
55import ProjectM36.TupleSet
66import ProjectM36.Error
77import ProjectM36.Transaction
8−import qualified Data.Map as M
8+import qualified ProjectM36.Attribute as A
99import qualified Data.HashSet as HS
1010import qualified Data.Set as S
11+import qualified Data.Vector as V
1112
1213showTransactionStructure :: Transaction -> TransactionGraph -> String
1314showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo
@@ -25,38 +26,36 @@ showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" trans
2526--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
2627graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
2728graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _ transSet) = do
28− tupleSet <- mapM tupleGenerator (S.toList transSet)
29− mkRelation attributeSet (HS.fromList tupleSet)
29+ tupleMatrix <- mapM tupleGenerator (S.toList transSet)
30+ mkRelationFromList attrs tupleMatrix
3031 where
31− attributeSet = M.fromList [("id", Attribute "id" StringAtomType),
32− ("parents", Attribute "parents" (RelationAtomType parentAttributes)),
33− ("current", Attribute "current" IntAtomType),
34− ("head", Attribute "head" StringAtomType)
35− ]
36− parentAttributes = M.fromList [("id", Attribute "id" StringAtomType)]
32+ attrs = A.attributesFromList [Attribute "id" StringAtomType,
33+ Attribute "parents" (RelationAtomType parentAttributes),
34+ Attribute "current" IntAtomType,
35+ Attribute "head" StringAtomType
36+ ]
37+ parentAttributes = A.attributesFromList [Attribute "id" StringAtomType]
3738 tupleGenerator transaction = case transactionParentsRelation transaction graph of
3839 Left err -> Left err
39− Right parentTransRel -> Right $ mkRelationTuple (S.fromList ["id", "parents", "current", "head"]) $
40− (M.fromList
41− [("id", StringAtom $ show (transactionUUID transaction)),
42− ("parents", RelationAtom parentTransRel),
43− ("current", IntAtom $ if parentUUID == transactionUUID transaction then 1 else 0),
44− ("head", StringAtom $ case headNameForTransaction transaction graph of
45− Just headName -> headName
46− Nothing -> "")
47− ])
40+ Right parentTransRel -> Right [StringAtom $ show (transactionUUID transaction),
41+ RelationAtom parentTransRel,
42+ IntAtom $ if parentUUID == transactionUUID transaction then 1 else 0,
43+ StringAtom $ case headNameForTransaction transaction graph of
44+ Just headName -> headName
45+ Nothing -> ""
46+ ]
4847
4948transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
5049transactionParentsRelation trans graph = do
5150 if isRootTransaction trans graph then do
52− mkRelation attributes emptyTupleSet
51+ mkRelation attrs emptyTupleSet
5352 else do
5453 parentTransSet <- parentTransactions trans graph
5554 let tupleSet = HS.fromList $ map trans2tuple (S.toList parentTransSet)
56− mkRelation attributes tupleSet
55+ mkRelation attrs tupleSet
5756 where
58− attributes = M.fromList [("id", Attribute "id" StringAtomType)]
59− trans2tuple trans2 = mkRelationTuple (S.fromList ["id"]) $ M.singleton "id" (StringAtom (show $ transactionUUID trans2))
57+ attrs = A.attributesFromList [Attribute "id" StringAtomType]
58+ trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (StringAtom (show $ transactionUUID trans2))
6059
6160
6261
ProjectM36/Tuple.hs+122−37
@@ -1,53 +1,67 @@
11module ProjectM36.Tuple where
22import ProjectM36.Base
3+import ProjectM36.Error
34import ProjectM36.Attribute
5+import ProjectM36.Atom
46
57import qualified Data.Map as M
68import qualified Data.Set as S
7−import qualified Data.List as L
89import 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
915
1016tupleSize :: RelationTuple -> Int
11−tupleSize (RelationTuple m) = M.size m
17+tupleSize (RelationTuple tupAttrs _) = V.length tupAttrs
1218
1319tupleAttributeNameSet :: RelationTuple -> S.Set AttributeName
14−tupleAttributeNameSet (RelationTuple tupMap) = M.keysSet tupMap
20+tupleAttributeNameSet (RelationTuple tupAttrs _) = S.fromList $ V.toList $ V.map attributeName tupAttrs
1521
1622tupleAttributes :: 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
1838 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+
2050
21−tupleAtomForAttribute :: RelationTuple -> AttributeName -> Atom
22−tupleAtomForAttribute (RelationTuple tupMap) attrName = tupMap M.! attrName
2351
24−{-instance Show RelationTuple where
25− show (RelationTuple t) = show $ M.toAscList t-}
26−
2752--in case the oldattr does not exist in the tuple, then return the old tuple
2853tupleRenameAttribute :: AttributeName -> AttributeName -> RelationTuple -> RelationTuple
29−tupleRenameAttribute oldattr newattr old@(RelationTuple tmap) =
30− if M.notMember oldattr tmap
31− then old
32− else
33− RelationTuple newmap
54+tupleRenameAttribute oldattr newattr (RelationTuple tupAttrs tupVec) = RelationTuple newAttrs tupVec
3455 where
35− newmap = M.insert newattr oldvalue deletedKeyMap
36− oldvalue = tmap M.! oldattr
37− deletedKeyMap = M.delete oldattr tmap
56+ newAttrs = renameAttributes oldattr newattr tupAttrs
3857
39−--in case the map does not contain the attributes, filter them out
40−mkRelationTuple :: S.Set AttributeName-> M.Map AttributeName Atom -> RelationTuple
41−mkRelationTuple attrs attrmap = RelationTuple newMap
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
58+mkRelationTuple :: Attributes -> V.Vector Atom -> RelationTuple
59+mkRelationTuple attrs atoms = RelationTuple attrs atoms
4660
47−mkRelationTuples :: Attributes -> [M.Map AttributeName Atom] -> [RelationTuple]
48−mkRelationTuples attrs maplist = map mapper maplist
61+mkRelationTuples :: Attributes -> [V.Vector Atom] -> [RelationTuple]
62+mkRelationTuples attrs atomsVec = map mapper atomsVec
4963 where
50− mapper m = RelationTuple $ remapWithAttributes (attributeNameSet attrs) m
64+ mapper = mkRelationTuple attrs
5165
5266singleTupleSetJoin :: RelationTuple -> RelationTupleSet -> RelationTupleSet
5367singleTupleSetJoin tup tupSet = HS.foldr tupleJoiner HS.empty tupSet
@@ -57,20 +71,91 @@ singleTupleSetJoin tup tupSet = HS.foldr tupleJoiner HS.empty tupSet
5771 Just relTuple -> HS.insert relTuple accumulator
5872 where joinedTuple = singleTupleJoin tup tuple2
5973
74+-- the keys/values don't need to be resorted
75+-- if the keys share some keys and values, then merge the tuples
6076singleTupleJoin :: 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
6294 where
63− newTuple = if M.isSubmapOfBy (==) matchingMap tup2 then
64− Just $ RelationTuple (M.union tup1 tup2)
95+ folder e acc = if V.elem e v1 then
96+ acc
6597 else
66− Nothing
67− matchingMap = M.intersection tup1 tup2
68−
98+ V.snoc acc e
6999
100+--precondition- no overlap in attributes
70101tupleExtend :: 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
72106
73107{- sort the associative list to match the header sorting -}
74108tupleSortedAssocs :: RelationTuple -> [(AttributeName, Atom)]
75−tupleSortedAssocs (RelationTuple tupMap) = L.sortBy (\x y -> compare (fst x) (fst y)) (M.assocs tupMap)
76−
109+tupleSortedAssocs (RelationTuple tupAttrs tupVec) = V.toList $ V.map (\(index,attr) -> (attributeName attr, tupVec V.! index)) $ V.indexed tupAttrs
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 @@
11module ProjectM36.TupleSet where
22import ProjectM36.Base
33import ProjectM36.Tuple
4−import ProjectM36.Attribute
54import ProjectM36.Error
6−import qualified Data.Map as M
75import qualified Data.HashSet as HS
86import Control.Monad
7+import qualified Data.Vector as V
98
109emptyTupleSet :: RelationTupleSet
1110emptyTupleSet = HS.empty
1211
13−emptyAttributeSet :: Attributes
14−emptyAttributeSet = M.empty
12+singletonTupleSet :: RelationTupleSet
13+singletonTupleSet = HS.singleton emptyTuple
1514
1615--ensure that all maps have the same keys and key count
1716
18−verifyRelationTupleSet :: Attributes -> RelationTupleSet -> Either RelationalError RelationTupleSet
19−verifyRelationTupleSet attrs tupleSet = do
17+verifyTupleSet :: Attributes -> RelationTupleSet -> Either RelationalError RelationTupleSet
18+verifyTupleSet attrs tupleSet = do
2019 --check that all tuples have the same types
2120 tupleList <- forM (HS.toList tupleSet) verifyTuple
2221 return $ HS.fromList tupleList
22+
23+mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTupleSet
24+mkTupleSet attrs tuples = verifyTupleSet attrs tupSet
2325 where
24− verifyTuple tuple = if tupleAttributes tuple == attrs then
25− Right tuple
26− else
27− Left $ TupleAttributeTypeMismatchError (attributesDifference (tupleAttributes tuple) attrs)
26+ tupSet = HS.fromList tuples
27+
28+mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet
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
55import ProjectM36.Tuple
66import ProjectM36.TupleSet
77import ProjectM36.Error
8+import qualified ProjectM36.Attribute as A
89import ProjectM36.RelationalExpression
910import ProjectM36.Relation.Show.Term
1011import ProjectM36.StaticOptimizer
1112import ProjectM36.Transaction
1213import ProjectM36.Transaction.Show
14+import ProjectM36.Atom
1315import Text.Parsec
1416import Text.Parsec.String
1517import Text.Parsec.Expr
@@ -26,6 +28,7 @@ import System.IO
2628import System.Directory (getHomeDirectory)
2729import qualified Data.UUID as U
2830import Data.UUID.V4 (nextRandom)
31+import qualified Data.Vector as V
2932
3033{-
3134List of Tutorial D operators:
@@ -72,8 +75,8 @@ attributeList = sepBy identifier comma
7275makeRelation :: Parser RelationalExpr
7376makeRelation = do
7477 reservedOp "relation"
75− attrs <- (try makeAttributes <|> return M.empty)
76− if not (M.null attrs) then do
78+ attrs <- (try makeAttributes <|> return A.emptyAttributes)
79+ if not (A.null attrs) then do
7780 return $ MakeStaticRelation attrs emptyTupleSet
7881 else do
7982 tuples <- braces (sepBy tupleP comma)
@@ -83,9 +86,7 @@ makeRelation = do
8386makeAttributes :: Parser Attributes
8487makeAttributes = do
8588 attrList <- braces (sepBy attributeAndType comma)
86− return $ M.fromList $ map toAttributeAssocList attrList
87− where
88− toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
89+ return $ A.attributesFromList attrList
8990
9091attributeAndType :: Parser Attribute
9192attributeAndType = do
@@ -99,8 +100,10 @@ attributeAndType = do
99100tupleP :: Parser RelationTuple
100101tupleP = do
101102 reservedOp "tuple"
102− attrValues <- braces (sepBy tupleAtomP comma)
103− return $ RelationTuple (M.fromList attrValues)
103+ attrAssocs <- braces (sepBy tupleAtomP comma)
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
104107
105108tupleAtomP :: Parser (AttributeName, Atom)
106109tupleAtomP = do
@@ -375,8 +378,7 @@ showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribu
375378 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
376379 Just t -> show t
377380 Nothing -> "unknown"
378− attrs = values (attributes rel)
379− values m = map snd (M.toAscList m)
381+ attrs = V.toList $ attributes rel
380382
381383data TutorialDOperatorResult = QuitResult |
382384 DisplayResult String |
@@ -497,7 +499,7 @@ interpretNO context tutdstring = case parseString tutdstring of
497499
498500-- for interpreter-specific operations
499501interpretOps :: 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
501503 Left err -> (trans, transGraph, NoActionResult)
502504 Right ops -> case ops of
503505 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
@@ -509,7 +511,7 @@ promptText :: DisconnectedTransaction -> TransactionGraph -> String
509511promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "
510512 where
511513 transInfo = case transactionForUUID parentUUID graph of
512− Left err -> "unknown"
514+ Left _ -> "unknown"
513515 Right parentTrans -> case headNameForTransaction parentTrans graph of
514516 Nothing -> show $ transactionUUID parentTrans
515517 Just headName -> headName
TutorialD/tutd.hs+1
@@ -4,6 +4,7 @@ import ProjectM36.Transaction
44import ProjectM36.Base
55import Data.UUID.V4 (nextRandom)
66
7+main :: IO ()
78main = do
89 freshUUID <- nextRandom
910 let currentHeadName = "master"
project-m36.cabal+1−1
@@ -7,7 +7,7 @@ Category: Relational Algebra
77Cabal-Version: >= 1.2
88
99Library
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
1111 Exposed-Modules: ProjectM36.Error,
1212 ProjectM36.Transaction,
1313 ProjectM36.Transaction.Show,
test/Relation/Basic.hs+33−30
@@ -3,28 +3,31 @@ import ProjectM36.Base
33import ProjectM36.Relation
44import ProjectM36.Error
55import ProjectM36.Tuple
6−import ProjectM36.TupleSet
7−import qualified Data.Set as S
8−import qualified Data.Map as M
6+import ProjectM36.Atom
7+import qualified ProjectM36.Attribute as A
98import qualified Data.HashSet as HS
9+import qualified Data.Vector as V
1010import System.Exit
11−import Control.Monad
1211
13−testList = TestList [testRelation relationTrue, testRelation relationFalse,
12+testList :: Test
13+testList = TestList [testRelation "relationTrue" relationTrue, testRelation "relationFalse" relationFalse,
14+ testMkRelation1,
1415 testRename1, testRename2]
16+
17+main :: IO ()
1518main = do
16− counts <- runTestTT testList
17− if errors counts + failures counts > 0 then exitFailure else exitSuccess
19+ tcounts <- runTestTT testList
20+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
1821
19−testRelation :: Relation -> Test
20−testRelation rel = TestCase $ assertEqual "nope" relationValidation (Right rel)
22+testRelation :: String -> Relation -> Test
23+testRelation testName rel = TestCase $ assertEqual testName relationValidation (Right rel)
2124 where
2225 relationValidation = validateRelation rel
2326
2427-- run common relation checks
2528validateRelation :: Relation -> Either RelationalError Relation
2629validateRelation rel = do
27− validateAttrNamesMatchTupleAttrNames rel
30+ _ <- validateAttrNamesMatchTupleAttrNames rel
2831 validateAttrTypesMatchTupleAttrTypes rel
2932
3033validateAttrNamesMatchTupleAttrNames :: Relation -> Either RelationalError Relation
@@ -32,30 +35,30 @@ validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupMapSet)
3235 | HS.null invalidSet = Right rel
3336 | otherwise = Left $ AttributeNameMismatchError ""
3437 where
35− nameCheck (RelationTuple tupMap) = attributeNames rel == M.keysSet tupMap
36− relAttrNames = attributeNames rel
38+ nameCheck tuple = attributeNames rel == tupleAttributeNameSet tuple
3739 invalidSet = HS.filter (not . nameCheck) tupMapSet
3840
39−
4041validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation
41−validateAttrTypesMatchTupleAttrTypes rel@(Relation _ tupMapSet)
42− | HS.null invalidSet = Right rel
43− | otherwise = Left (TupleAttributeTypeMismatchError M.empty) --fix to include invalid attrs
42+validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = HS.foldr (\tuple acc ->
43+ if (tupleAttributes tuple) == attrs && tupleAtomCheck tuple then
44+ acc
45+ else
46+ Left $ TupleAttributeTypeMismatchError A.emptyAttributes
47+ ) (Right rel) tupSet
4448 where
45− tupleTypeCheck (RelationTuple tupMap) = M.null $ M.filterWithKey attrTypeCheck tupMap
46− attrTypeCheck attrName atomValue = case attributeTypeForName attrName rel of
47− Just t -> atomValueType atomValue == t
48− _ -> False
49− invalidSet = HS.filter (not . tupleTypeCheck) tupMapSet
49+ tupleAtomCheck tuple = V.all (== True) (attrChecks tuple)
50+ attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of
51+ Left _ -> False
52+ Right atom -> (Just $ atomTypeForAtom atom) ==
53+ A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel)
5054
55+simpleRel :: Relation
5156simpleRel = case mkRelation attrs tupleSet of
5257 Right rel -> rel
53− Left err -> undefined
58+ Left _ -> undefined
5459 where
55− attrs = M.fromList [("a", Attribute "a" StringAtomType), ("b", Attribute "b" StringAtomType)]
56− tupleSet = HS.fromList $ mkRelationTuples attrs [
57− M.fromList [("a", StringAtom "spam"), ("b", StringAtom "spam2")]
58− ]
60+ attrs = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" StringAtomType]
61+ tupleSet = HS.singleton $ mkRelationTuple attrs (V.fromList [StringAtom "spam", StringAtom "spam2"])
5962
6063--rename tests
6164testRename1 :: Test
@@ -67,8 +70,8 @@ testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRe
6770--mkRelation tests
6871--test tupleset key mismatch failure
6972testMkRelation1 :: 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)
7174 where
72− testAttrs = M.singleton "a" (Attribute "a" StringAtomType)
73− testTupSet = HS.fromList [(RelationTuple (M.singleton "a" $ StringAtom "v")),
74− RelationTuple (M.singleton "a" $ IntAtom 2)]
75+ testAttrs = A.attributesFromList [Attribute "a" StringAtomType]
76+ testTupSet = HS.fromList [mkRelationTuple testAttrs $ V.fromList [StringAtom "v"],
77+ mkRelationTuple testAttrs $ V.fromList [IntAtom 2]]
test/Relation/StaticOptimizer.hs+6−7
@@ -6,20 +6,20 @@ import ProjectM36.StaticOptimizer
66import System.Exit
77import Control.Monad.State
88import Test.HUnit
9−import qualified Data.Set as S
109
10+main :: IO ()
1111main = do
12− counts <- runTestTT (TestList tests)
13− if errors counts + failures counts > 0 then exitFailure else exitSuccess
12+ tcounts <- runTestTT (TestList tests)
13+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
1414 where
1515 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
1717 relationOptTests = optTest applyStaticRelationalOptimization [
18− ("StaticProject", Right $ RelationVariable "S", Project (attributeNames s) (RelationVariable "S")),
18+ ("StaticProject", Right $ RelationVariable "S", Project (attributeNames suppliersRel) (RelationVariable "S")),
1919 ("StaticUnion", Right $ RelationVariable "S", Union (RelationVariable "S") (RelationVariable "S")),
2020 ("StaticJoin", Right $ RelationVariable "S", Join (RelationVariable "S") (RelationVariable "S")),
2121 ("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"))
2323 ]
2424 databaseOptTests = optTest applyStaticDatabaseOptimization [
2525 ("StaticAssign",
@@ -32,4 +32,3 @@ main = do
3232 MultipleExpr [Assign "z" (Restrict TruePredicate (RelationVariable "S")),
3333 Assign "z" (Restrict TruePredicate (RelationVariable "S"))])
3434 ]
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
22import Test.HUnit
33import ProjectM36.RelationalExpression
44import ProjectM36.Relation
5+import ProjectM36.Tuple
6+import ProjectM36.TupleSet
57import ProjectM36.Error
68import ProjectM36.Base
79import ProjectM36.Transaction
10+import qualified ProjectM36.Attribute as A
811import qualified Data.HashSet as HS
912import qualified Data.Map as M
1013import qualified Data.Set as S
@@ -12,20 +15,22 @@ import System.Exit
1215import Data.UUID.V4 (nextRandom)
1316import Data.UUID (nil)
1417import Data.Either (isRight)
18+import qualified Data.Vector as V
1519
20+main :: IO ()
1621main = do
17− counts <- runTestTT (TestList tests)
18− if errors counts + failures counts > 0 then exitFailure else exitSuccess
22+ tcounts <- runTestTT (TestList tests)
23+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
1924 where
2025 tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest]
2126 simpleRelTests = [("x:=true", Right relationTrue),
2227 ("x:=false", Right relationFalse),
2328 ("x:=true union false", Right relationTrue),
2429 ("x:=true; x:=false", Right relationFalse),
25− ("x:=relation{a int}", mkRelation simpleAAttributes HS.empty),
26− ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes HS.empty),
27− ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes HS.empty),
28− ("x:=relation{tuple{a char(\"spam\"), b int(5)}}", mkRelation simpleCAttributes (HS.fromList $ map RelationTuple [M.fromList [("a", StringAtom "spam"),("b",IntAtom 5)]])),
30+ ("x:=relation{a int}", mkRelation simpleAAttributes emptyTupleSet),
31+ ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),
32+ ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),
33+ ("x:=relation{tuple{a char(\"spam\"), b int(5)}}", mkRelation simpleCAttributes $ HS.singleton ((RelationTuple simpleCAttributes) (V.fromList [StringAtom "spam", IntAtom 5]))),
2934 ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),
3035 ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),
3136 ("x:=true where true", Right relationTrue),
@@ -37,20 +42,20 @@ main = do
3742 ("x:=true=true", Right relationTrue),
3843 ("x:=true=false", Right relationFalse),
3944 ("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)]])),
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)]])
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]])),
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]))
4247 ]
43− simpleAAttributes = M.fromList [("a", Attribute "a" IntAtomType)]
44− simpleBAttributes = M.fromList [("d", Attribute "d" IntAtomType)]
45− simpleCAttributes = M.fromList [("a", Attribute "a" StringAtomType), ("b", Attribute "b" IntAtomType)]
46− simpleProjectionAttributes = M.fromList [("c", Attribute "c" IntAtomType)]
47− dateExampleRelTests = [("x:=S where true", Right s),
48− ("x:=S where CITY = \"London\"", restrict (\(RelationTuple tupMap) -> tupMap M.! "CITY" == StringAtom "London") s),
49− ("x:=S where false", Right $ Relation (attributes s) HS.empty),
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)]])),
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)
48+ simpleAAttributes = A.attributesFromList [Attribute "a" IntAtomType]
49+ simpleBAttributes = A.attributesFromList [Attribute "d" IntAtomType]
50+ simpleCAttributes = A.attributesFromList [Attribute "a" StringAtomType, Attribute "b" IntAtomType]
51+ simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntAtomType]
52+ dateExampleRelTests = [("x:=S where true", Right suppliersRel),
53+ ("x:=S where CITY = \"London\"", restrict (\tuple -> atomForAttributeName "CITY" tuple == (Right $ StringAtom "London")) suppliersRel),
54+ ("x:=S where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),
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]))),
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)
5257 ]
53−
58+assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion
5459assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted
5560 where
5661 interpreted = case interpret databaseContext tutd of
@@ -59,47 +64,51 @@ assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interp
5964 Nothing -> Left $ RelVarNotDefinedError "x"
6065 Just rel -> Right rel
6166
67+transactionGraphBasicTest :: Test
6268transactionGraphBasicTest = TestCase $ do
63− (discon, graph) <- dateExamplesGraph
69+ (_, graph) <- dateExamplesGraph
6470 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
6571
6672--add a new transaction to the graph, validate it is in the graph
73+transactionGraphAddCommitTest :: Test
6774transactionGraphAddCommitTest = TestCase $ do
68− (discon@(DisconnectedTransaction firstUUID context), graph) <- dateExamplesGraph
75+ ((DisconnectedTransaction firstUUID context), origGraph) <- dateExamplesGraph
6976 freshUUID <- nextRandom
7077 case interpret context "x:=S" of
71− (Just err, newContext) -> assertFailure (show err)
78+ (Just err, _) -> assertFailure (show err)
7279 (Nothing, newContext) -> do
7380 let discon = newDisconnectedTransaction firstUUID newContext
74− let addTrans = addDisconnectedTransaction freshUUID "master" discon graph
81+ let addTrans = addDisconnectedTransaction freshUUID "master" discon origGraph
7582 case addTrans of
7683 Left err -> assertFailure (show err)
7784 Right (newTrans, graph) -> do
7885 assertBool "transaction in graph" (isRight $ transactionForUUID freshUUID graph)
7986 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)
8188
89+transactionRollbackTest :: Test
8290transactionRollbackTest = TestCase $ do
83− (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
91+ ((DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
8492 freshUUID <- nextRandom
8593 case transactionForUUID firstUUID graph of
8694 Left err -> assertFailure (show err)
87− Right firstTrans -> do
95+ Right _ -> do
8896 case interpret origContext "x:=S" of
8997 (Just err, _) -> assertFailure (show err)
9098 (Nothing, newContext) -> do
9199 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"
93101 assertEqual "validate context" (M.lookup "x" (relationVariables newContext2)) Nothing
94102 assertEqual "validate graph" graph newGraph
95103
96104--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
105+transactionJumpTest :: Test
97106transactionJumpTest = TestCase $ do
98− (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
107+ ((DisconnectedTransaction firstUUID origContext), origGraph) <- dateExamplesGraph
99108 freshUUID <- nextRandom
100− case transactionForUUID firstUUID graph of
109+ case transactionForUUID firstUUID origGraph of
101110 Left err -> assertFailure (show err)
102− Right firstTrans -> do
111+ Right _ -> do
103112 case interpret origContext "x:=S" of
104113 (Just err, _) -> assertFailure (show err)
105114 (Nothing, newContext) -> do
@@ -109,12 +118,12 @@ transactionJumpTest = TestCase $ do
109118 (Nothing, newContext2) -> do
110119 --add the transaction
111120 let discon = newDisconnectedTransaction firstUUID newContext2
112− let addTrans = addDisconnectedTransaction freshUUID "master" discon graph
121+ let addTrans = addDisconnectedTransaction freshUUID "master" discon origGraph
113122 case addTrans of
114123 Left err -> assertFailure (show err)
115− Right (newTrans, graph) -> do
124+ Right (_, graph) -> do
116125 --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)
118127 assertEqual "validate discon" parentUUID firstUUID
119128 assertEqual "validate discon2" Nothing (M.lookup "x" (relationVariables newContext3))
120129 assertEqual "validate graph" transactionUUIDs (S.map transactionUUID (transactionsForGraph newGraph))
@@ -122,21 +131,22 @@ transactionJumpTest = TestCase $ do
122131 transactionUUIDs = S.fromList [firstUUID, freshUUID]
123132
124133--branch from the first transaction and verify that there are two heads
134+transactionBranchTest :: Test
125135transactionBranchTest = TestCase $ do
126− (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
136+ (origDiscon@(DisconnectedTransaction firstUUID origContext), origGraph) <- dateExamplesGraph
127137 freshUUID1 <- nextRandom
128138 freshUUID2 <- nextRandom
129− case transactionForUUID firstUUID graph of
139+ case transactionForUUID firstUUID origGraph of
130140 Left err -> assertFailure (show err)
131− Right firstTrans -> do
141+ Right _ -> do
132142 let disconMaster = newDisconnectedTransaction firstUUID origContext
133− let addTransMaster = addDisconnectedTransaction freshUUID1 "master" disconMaster graph
143+ let addTransMaster = addDisconnectedTransaction freshUUID1 "master" disconMaster origGraph
134144 --add a second transaction to the "master" branch
135145 case addTransMaster of
136146 Left err -> assertFailure (show err)
137− Right (newTrans, graph) -> do
147+ Right (_, graph) -> do
138148 --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"
140150 assertEqual "verify test head" freshUUID2 $ maybeTransUUID (transactionForHead "test" newGraph)
141151 assertEqual "verify master head" freshUUID1 $ maybeTransUUID (transactionForHead "master" newGraph)
142152 where