@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
12module ProjectM36.Attribute where
23import ProjectM36.Base
34import ProjectM36.Error
@@ -10,16 +11,45 @@ import qualified Data.Map as M
1011import Data.Either
1112
1213arity :: Attributes -> Int
13−arity = V.length
14+arity a = V.length (attributesVec a)
15+
16+instance Semigroup Attributes where
17+ attrsA <> attrsB =
18+ case joinAttributes attrsA attrsB of
19+ Left err -> error (show err)
20+ Right attrs' -> attrs'
21+
22+instance Monoid Attributes where
23+ mempty = Attributes mempty mempty
1424
1525emptyAttributes :: Attributes
16−emptyAttributes = V.empty
26+emptyAttributes = mempty
1727
1828null :: Attributes -> Bool
19−null = V.null
29+null a = V.null (attributesVec a)
30+
31+singleton :: Attribute -> Attributes
32+singleton attr = Attributes (V.singleton attr) (HS.singleton attr)
33+
34+toList :: Attributes -> [Attribute]
35+toList attrs = V.toList (attributesVec attrs)
2036
2137attributesFromList :: [Attribute] -> Attributes
22−attributesFromList = V.fromList -- . L.nub --too expensive
38+attributesFromList attrsL = Attributes vec hset
39+ where
40+ vec = if length attrsL == HS.size hset then
41+ --fast path- no duplicates
42+ V.fromList attrsL
43+ else
44+ --duplicate detected, uniqueify while maintaining original ordering
45+ V.fromList uniquedL
46+ hset = HS.fromList attrsL
47+ uniquedL = fst $ foldr (\attr acc@(l,s) ->
48+ if HS.member attr s then
49+ acc
50+ else
51+ (l ++ [attr], HS.insert attr s))
52+ ([],mempty) attrsL
2353
2454attributeName :: Attribute -> AttributeName
2555attributeName (Attribute name _) = name
@@ -28,17 +58,16 @@ atomType :: Attribute -> AtomType
2858atomType (Attribute _ atype) = atype
2959
3060atomTypes :: Attributes -> V.Vector AtomType
31−atomTypes = V.map atomType
61+atomTypes attrs = V.map atomType (attributesVec attrs)
3262
3363atomTypesList :: Attributes -> [AtomType]
3464atomTypesList = V.toList . atomTypes
3565
36−--hm- no error-checking here
3766addAttribute :: Attribute -> Attributes -> Attributes
38−addAttribute attr attrs = attrs `V.snoc` attr
67+addAttribute attr attrs = attrs <> singleton attr
3968
4069--if some attribute names overlap but the types do not, then spit back an error
41−joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes
70+{-joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes
4271joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length overlappingAttributes = Left (TupleAttributeTypeMismatchError overlappingAttributes)
4372 | V.length overlappingAttrsDifferentTypes > 0 = Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes)
4473 | otherwise = Right $ vectorUniqueify (attrs1 V.++ attrs2)
@@ -47,20 +76,47 @@ joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length
4776 attrNames2 = V.map attributeName attrs2
4877 uniqueOverlappingAttributes = vectorUniqueify overlappingAttributes
4978 overlappingAttributes = V.filter (`V.elem` attrs2) attrs1
79+-}
80+joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes
81+joinAttributes attrs1 attrs2 =
82+ if S.size overlappingNames == 0 then -- fast path, no overlapping names
83+ pure (concated id)
84+ else if attributesForNames overlappingNames attrs1 == attributesForNames overlappingNames attrs2 then -- check that atomtypes match
85+ pure (concated vectorUniqueify)
86+ else
87+ --special handling to validate that overlapping names have the same atom types
88+ Left (TupleAttributeTypeMismatchError (attributesForNames overlappingNames attrs1))
89+ where
90+ nameSet1 = attributeNameSet attrs1
91+ nameSet2 = attributeNameSet attrs2
92+ overlappingNames = S.intersection nameSet1 nameSet2
93+ concated f = Attributes (f (attributesVec attrs1 <> attributesVec attrs2)) (attributesSet attrs1 <> attributesSet attrs2)
5094
5195addAttributes :: Attributes -> Attributes -> Attributes
52−addAttributes = (V.++)
96+addAttributes = (<>)
97+
98+member :: Attribute -> Attributes -> Bool
99+member attr attrs = HS.member attr (attributesSet attrs)
53100
54101deleteAttributeName :: AttributeName -> Attributes -> Attributes
55−deleteAttributeName attrName = V.filter (\attr -> attributeName attr /= attrName)
102+deleteAttributeName attrName attrs = deleteAttributeNames (S.singleton attrName) attrs
103+
104+deleteAttributeNames :: S.Set AttributeName -> Attributes -> Attributes
105+deleteAttributeNames attrNames attrs = Attributes vec hset
106+ where
107+ vec = V.filter attrFilter (attributesVec attrs)
108+ hset = HS.filter attrFilter (attributesSet attrs)
109+ attrFilter attr = S.notMember (attributeName attr) attrNames
56110
57111renameAttribute :: AttributeName -> Attribute -> Attribute
58112renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo
59113
60114renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes
61−renameAttributes oldAttrName newAttrName = V.map renamer
115+renameAttributes oldAttrName newAttrName attrs = Attributes vec hset
62116 where
63− renamer attr = if attributeName attr == oldAttrName then
117+ vec = V.map renamer (attributesVec attrs)
118+ hset = HS.map renamer (attributesSet attrs)
119+ renamer attr = if attributeName attr == oldAttrName then
64120 renameAttribute newAttrName attr
65121 else
66122 attr
@@ -71,7 +127,7 @@ atomTypeForAttributeName attrName attrs = do
71127 return atype
72128
73129attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute
74−attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) attrs of
130+attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) (attributesVec attrs) of
75131 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))
76132 Just attr -> Right attr
77133
@@ -89,15 +145,18 @@ projectionAttributesForNames names attrsIn =
89145 missingNames = attributeNamesNotContained names (S.fromList (V.toList (attributeNames attrsIn)))
90146
91147attributesForNames :: S.Set AttributeName -> Attributes -> Attributes
92−attributesForNames attrNameSet = V.filter filt
148+attributesForNames attrNameSet attrs = Attributes vec hset
149+
93150 where
151+ vec = V.filter filt (attributesVec attrs)
152+ hset = HS.filter filt (attributesSet attrs)
94153 filt attr = S.member (attributeName attr) attrNameSet
95154
96155attributeNameSet :: Attributes -> S.Set AttributeName
97−attributeNameSet attrVec = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) attrVec
156+attributeNameSet attrs = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) (attributesVec attrs)
98157
99158attributeNames :: Attributes -> V.Vector AttributeName
100−attributeNames = V.map attributeName
159+attributeNames attrs = V.map attributeName (attributesVec attrs)
101160
102161--checks if set s1 is wholly contained in the set s2
103162attributesContained :: Attributes -> Attributes -> Bool
@@ -118,42 +177,70 @@ attributeNamesNotContained subset superset = S.filter (`S.notMember` superset) s
118177
119178-- useful for display
120179orderedAttributes :: Attributes -> [Attribute]
121−orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList attrs)
180+orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList (attributesVec attrs))
122181
123182orderedAttributeNames :: Attributes -> [AttributeName]
124183orderedAttributeNames attrs = map attributeName (orderedAttributes attrs)
125184
126185-- take two attribute sets and return an attribute set with the attributes which do not match
186+--this is the function which benefits the most from the HashSet representation- this turned up in the insert performance test
127187attributesDifference :: Attributes -> Attributes -> Attributes
128−attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)
188+{-attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)
129189 where
130190 diff a b = (a L.\\ b) ++ (b L.\\ a)
191+-}
192+attributesDifference attrsA attrsB =
193+ if attributesSet attrsA == attributesSet attrsB then
194+ mempty
195+ else
196+ Attributes vec hset
197+ where
198+ hset = HS.difference setA setB <> HS.difference setB setA
199+ setA = attributesSet attrsA
200+ setB = attributesSet attrsB
201+ vec = V.filter (\attr -> HS.member attr hset) (attributesVec attrsA <> attributesVec attrsB)
131202
132203vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a
133204vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn
134205
135206--check that each attribute only appears once
136207verifyAttributes :: Attributes -> Either RelationalError Attributes
137−verifyAttributes attrs = if collapsedAttrs /= attrs then
138− Left (TupleAttributeTypeMismatchError (attributesDifference collapsedAttrs attrs))
139− else
140− Right attrs
208+verifyAttributes attrs =
209+ if vecSet == attributesSet attrs then
210+ pure attrs
211+ else
212+ Left (TupleAttributeTypeMismatchError diffAttrs)
141213 where
142− collapsedAttrs = vectorUniqueify attrs
143−
214+ vecSet = V.foldr' HS.insert HS.empty (attributesVec attrs)
215+ diffSet = HS.difference vecSet (attributesSet attrs) <> HS.difference (attributesSet attrs) vecSet
216+ diffAttrs = Attributes (V.fromList (HS.toList diffSet)) diffSet
217+
218+--used in Generics derivation for ADTs without named attributes- not to be used elsewhere
219+--drop first n attributes from vector representation
220+drop :: Int -> Attributes -> Attributes
221+drop c attrs = Attributes vec hset
222+ where
223+ droppedAttrs = V.take c (attributesVec attrs)
224+ vec = V.drop c (attributesVec attrs)
225+ hset = HS.filter (`V.notElem` droppedAttrs) hset
226+
227+-- use this in preference to (==) when the attribute ordering matters such as during tuple unions
144228attributesEqual :: Attributes -> Attributes -> Bool
145−attributesEqual attrs1 attrs2 = V.null (attributesDifference attrs1 attrs2)
229+attributesEqual a b = attributesVec a == attributesVec b
146230
147231attributesAsMap :: Attributes -> M.Map AttributeName Attribute
148−attributesAsMap attrs = (M.fromList . V.toList) (V.map (\attr -> (attributeName attr, attr)) attrs)
232+attributesAsMap attrs = V.foldr' (\attr acc -> M.insert (attributeName attr) attr acc) mempty (attributesVec attrs)
233+
149234
150235-- | Left-biased union of attributes.
151236union :: Attributes -> Attributes -> Attributes
152−union attrsA attrsB = V.fromList (M.elems unioned)
237+union attrsA attrsB = Attributes vec hset
153238 where
154− unioned = M.union (attributesAsMap attrsA) (attributesAsMap attrsB)
239+ hset = HS.union (attributesSet attrsA) (attributesSet attrsB)
240+ vec = HS.foldr (flip V.snoc) mempty hset
155241
156242intersection :: Attributes -> Attributes -> Attributes
157−intersection attrsA attrsB = V.fromList (M.elems intersected)
243+intersection attrsA attrsB = Attributes vec hset
158244 where
159− intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)
245+ hset = HS.intersection (attributesSet attrsA) (attributesSet attrsB)
246+ vec = HS.foldr (flip V.snoc) mempty hset