git.iko.soy/project-m36
on 18f736a help sign in
project-m36/src/lib/ProjectM36/Attribute.hs
152 lines 6.6 kB history raw
1module ProjectM36.Attribute where
2import ProjectM36.Base
3import ProjectM36.Error
4import qualified Data.Set as S
5import qualified Data.List as L
6import qualified Data.Vector as V
7import qualified Data.Hashable as Hash
8import qualified Data.HashSet as HS
9import qualified Data.Map as M
11arity :: Attributes -> Int
12arity = V.length
14emptyAttributes :: Attributes
15emptyAttributes = V.empty
17null :: Attributes -> Bool
18null = V.null
20attributesFromList :: [Attribute] -> Attributes
21attributesFromList = V.fromList -- . L.nub --too expensive
23attributeName :: Attribute -> AttributeName
24attributeName (Attribute name _) = name
26atomType :: Attribute -> AtomType
27atomType (Attribute _ atype) = atype
29atomTypes :: Attributes -> V.Vector AtomType
30atomTypes = V.map atomType
32--hm- no error-checking here
33addAttribute :: Attribute -> Attributes -> Attributes
34addAttribute attr attrs = attrs `V.snoc` attr
36--if some attribute names overlap but the types do not, then spit back an error
37joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes
38joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length overlappingAttributes = Left (TupleAttributeTypeMismatchError overlappingAttributes)
39 | V.length overlappingAttrsDifferentTypes > 0 = Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes)
40 | otherwise = Right $ vectorUniqueify (attrs1 V.++ attrs2)
41 where
42 overlappingAttrsDifferentTypes = V.filter (\attr -> V.elem (attributeName attr) attrNames2 && V.notElem attr attrs2) attrs1
43 attrNames2 = V.map attributeName attrs2
44 uniqueOverlappingAttributes = vectorUniqueify overlappingAttributes
45 overlappingAttributes = V.filter (`V.elem` attrs2) attrs1
47addAttributes :: Attributes -> Attributes -> Attributes
48addAttributes = (V.++)
50deleteAttributeName :: AttributeName -> Attributes -> Attributes
51deleteAttributeName attrName = V.filter (\attr -> attributeName attr /= attrName)
53renameAttribute :: AttributeName -> Attribute -> Attribute
54renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo
56renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes
57renameAttributes oldAttrName newAttrName = V.map renamer
58 where
59 renamer attr = if attributeName attr == oldAttrName then
60 renameAttribute newAttrName attr
61 else
62 attr
64atomTypeForAttributeName :: AttributeName -> Attributes -> Either RelationalError AtomType
65atomTypeForAttributeName attrName attrs = do
66 (Attribute _ atype) <- attributeForName attrName attrs
67 return atype
69attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute
70attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) attrs of
71 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))
72 Just attr -> Right attr
74--similar to attributesForNames, but returns error if some names are missing
75projectionAttributesForNames :: S.Set AttributeName -> Attributes -> Either RelationalError Attributes
76projectionAttributesForNames names attrsIn =
77 if not (S.null missingNames) then
78 Left (NoSuchAttributeNamesError missingNames)
79 else
80 Right (attributesForNames names attrsIn)
81 where
82 missingNames = attributeNamesNotContained names (S.fromList (V.toList (attributeNames attrsIn)))
84attributesForNames :: S.Set AttributeName -> Attributes -> Attributes
85attributesForNames attrNameSet = V.filter filt
86 where
87 filt attr = S.member (attributeName attr) attrNameSet
89attributeNameSet :: Attributes -> S.Set AttributeName
90attributeNameSet attrVec = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) attrVec
92attributeNames :: Attributes -> V.Vector AttributeName
93attributeNames = V.map attributeName
95--checks if set s1 is wholly contained in the set s2
96attributesContained :: Attributes -> Attributes -> Bool
97attributesContained attrs1 attrs2 = attributeNamesContained (attributeNameSet attrs1) (attributeNameSet attrs2)
99attributeNamesContained :: S.Set AttributeName -> S.Set AttributeName -> Bool
100attributeNamesContained = S.isSubsetOf
102--returns the disjunction of the AttributeNameSets
103nonMatchingAttributeNameSet :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName
104nonMatchingAttributeNameSet a1 a2 = S.difference (S.union a1 a2) (S.intersection a1 a2)
106matchingAttributeNameSet :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName
107matchingAttributeNameSet = S.intersection
109attributeNamesNotContained :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName
110attributeNamesNotContained subset superset = S.filter (`S.notMember` superset) subset
112-- useful for display
113orderedAttributes :: Attributes -> [Attribute]
114orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList attrs)
116orderedAttributeNames :: Attributes -> [AttributeName]
117orderedAttributeNames attrs = map attributeName (orderedAttributes attrs)
119-- take two attribute sets and return an attribute set with the attributes which do not match
120attributesDifference :: Attributes -> Attributes -> Attributes
121attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)
122 where
123 diff a b = (a L.\\ b) ++ (b L.\\ a)
125vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a
126vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn
128--check that each attribute only appears once
129verifyAttributes :: Attributes -> Either RelationalError Attributes
130verifyAttributes attrs = if collapsedAttrs /= attrs then
131 Left (TupleAttributeTypeMismatchError (attributesDifference collapsedAttrs attrs))
132 else
133 Right attrs
134 where
135 collapsedAttrs = vectorUniqueify attrs
137attributesEqual :: Attributes -> Attributes -> Bool
138attributesEqual attrs1 attrs2 = V.null (attributesDifference attrs1 attrs2)
140attributesAsMap :: Attributes -> M.Map AttributeName Attribute
141attributesAsMap attrs = (M.fromList . V.toList) (V.map (\attr -> (attributeName attr, attr)) attrs)
143-- | Left-biased union of attributes.
144union :: Attributes -> Attributes -> Attributes
145union attrsA attrsB = V.fromList (M.elems unioned)
146 where
147 unioned = M.union (attributesAsMap attrsA) (attributesAsMap attrsB)
149intersection :: Attributes -> Attributes -> Attributes
150intersection attrsA attrsB = V.fromList (M.elems intersected)
151 where
152 intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)