git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/lib/ProjectM36/Attribute.hs
159 lines 6.9 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
10import Data.Either
12arity :: Attributes -> Int
13arity = V.length
15emptyAttributes :: Attributes
16emptyAttributes = V.empty
18null :: Attributes -> Bool
19null = V.null
21attributesFromList :: [Attribute] -> Attributes
22attributesFromList = V.fromList -- . L.nub --too expensive
24attributeName :: Attribute -> AttributeName
25attributeName (Attribute name _) = name
27atomType :: Attribute -> AtomType
28atomType (Attribute _ atype) = atype
30atomTypes :: Attributes -> V.Vector AtomType
31atomTypes = V.map atomType
33atomTypesList :: Attributes -> [AtomType]
34atomTypesList = V.toList . atomTypes
36--hm- no error-checking here
37addAttribute :: Attribute -> Attributes -> Attributes
38addAttribute attr attrs = attrs `V.snoc` attr
40--if some attribute names overlap but the types do not, then spit back an error
41joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes
42joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length overlappingAttributes = Left (TupleAttributeTypeMismatchError overlappingAttributes)
43 | V.length overlappingAttrsDifferentTypes > 0 = Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes)
44 | otherwise = Right $ vectorUniqueify (attrs1 V.++ attrs2)
45 where
46 overlappingAttrsDifferentTypes = V.filter (\attr -> V.elem (attributeName attr) attrNames2 && V.notElem attr attrs2) attrs1
47 attrNames2 = V.map attributeName attrs2
48 uniqueOverlappingAttributes = vectorUniqueify overlappingAttributes
49 overlappingAttributes = V.filter (`V.elem` attrs2) attrs1
51addAttributes :: Attributes -> Attributes -> Attributes
52addAttributes = (V.++)
54deleteAttributeName :: AttributeName -> Attributes -> Attributes
55deleteAttributeName attrName = V.filter (\attr -> attributeName attr /= attrName)
57renameAttribute :: AttributeName -> Attribute -> Attribute
58renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo
60renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes
61renameAttributes oldAttrName newAttrName = V.map renamer
62 where
63 renamer attr = if attributeName attr == oldAttrName then
64 renameAttribute newAttrName attr
65 else
66 attr
68atomTypeForAttributeName :: AttributeName -> Attributes -> Either RelationalError AtomType
69atomTypeForAttributeName attrName attrs = do
70 (Attribute _ atype) <- attributeForName attrName attrs
71 return atype
73attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute
74attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) attrs of
75 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))
76 Just attr -> Right attr
78isAttributeNameContained :: AttributeName -> Attributes -> Bool
79isAttributeNameContained nam attrs = isRight (attributeForName nam attrs)
81--similar to attributesForNames, but returns error if some names are missing
82projectionAttributesForNames :: S.Set AttributeName -> Attributes -> Either RelationalError Attributes
83projectionAttributesForNames names attrsIn =
84 if not (S.null missingNames) then
85 Left (NoSuchAttributeNamesError missingNames)
86 else
87 Right (attributesForNames names attrsIn)
88 where
89 missingNames = attributeNamesNotContained names (S.fromList (V.toList (attributeNames attrsIn)))
91attributesForNames :: S.Set AttributeName -> Attributes -> Attributes
92attributesForNames attrNameSet = V.filter filt
93 where
94 filt attr = S.member (attributeName attr) attrNameSet
96attributeNameSet :: Attributes -> S.Set AttributeName
97attributeNameSet attrVec = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) attrVec
99attributeNames :: Attributes -> V.Vector AttributeName
100attributeNames = V.map attributeName
102--checks if set s1 is wholly contained in the set s2
103attributesContained :: Attributes -> Attributes -> Bool
104attributesContained attrs1 attrs2 = attributeNamesContained (attributeNameSet attrs1) (attributeNameSet attrs2)
106attributeNamesContained :: S.Set AttributeName -> S.Set AttributeName -> Bool
107attributeNamesContained = S.isSubsetOf
109--returns the disjunction of the AttributeNameSets
110nonMatchingAttributeNameSet :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName
111nonMatchingAttributeNameSet a1 a2 = S.difference (S.union a1 a2) (S.intersection a1 a2)
113matchingAttributeNameSet :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName
114matchingAttributeNameSet = S.intersection
116attributeNamesNotContained :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName
117attributeNamesNotContained subset superset = S.filter (`S.notMember` superset) subset
119-- useful for display
120orderedAttributes :: Attributes -> [Attribute]
121orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList attrs)
123orderedAttributeNames :: Attributes -> [AttributeName]
124orderedAttributeNames attrs = map attributeName (orderedAttributes attrs)
126-- take two attribute sets and return an attribute set with the attributes which do not match
127attributesDifference :: Attributes -> Attributes -> Attributes
128attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)
129 where
130 diff a b = (a L.\\ b) ++ (b L.\\ a)
132vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a
133vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn
135--check that each attribute only appears once
136verifyAttributes :: Attributes -> Either RelationalError Attributes
137verifyAttributes attrs = if collapsedAttrs /= attrs then
138 Left (TupleAttributeTypeMismatchError (attributesDifference collapsedAttrs attrs))
139 else
140 Right attrs
141 where
142 collapsedAttrs = vectorUniqueify attrs
144attributesEqual :: Attributes -> Attributes -> Bool
145attributesEqual attrs1 attrs2 = V.null (attributesDifference attrs1 attrs2)
147attributesAsMap :: Attributes -> M.Map AttributeName Attribute
148attributesAsMap attrs = (M.fromList . V.toList) (V.map (\attr -> (attributeName attr, attr)) attrs)
150-- | Left-biased union of attributes.
151union :: Attributes -> Attributes -> Attributes
152union attrsA attrsB = V.fromList (M.elems unioned)
153 where
154 unioned = M.union (attributesAsMap attrsA) (attributesAsMap attrsB)
156intersection :: Attributes -> Attributes -> Attributes
157intersection attrsA attrsB = V.fromList (M.elems intersected)
158 where
159 intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)