git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/lib/ProjectM36/Tuple.hs
210 lines 10 kB history raw
1module ProjectM36.Tuple where
2import ProjectM36.Base
3import ProjectM36.Error
4import ProjectM36.Attribute
5import ProjectM36.Atom
6import ProjectM36.AtomType
7import ProjectM36.DataTypes.Primitive
9import qualified Data.Map as M
10import qualified Data.Set as S
11import qualified Data.Vector as V
12import Data.Either (rights)
13import Control.Monad
14import Control.Arrow
15import Data.Maybe
17emptyTuple :: RelationTuple
18emptyTuple = RelationTuple V.empty V.empty
20tupleSize :: RelationTuple -> Int
21tupleSize (RelationTuple tupAttrs _) = V.length tupAttrs
23tupleAttributeNameSet :: RelationTuple -> S.Set AttributeName
24tupleAttributeNameSet (RelationTuple tupAttrs _) = S.fromList $ V.toList $ V.map attributeName tupAttrs
26tupleAttributes :: RelationTuple -> Attributes
27tupleAttributes (RelationTuple tupAttrs _) = tupAttrs
29tupleAssocs :: RelationTuple -> [(AttributeName, Atom)]
30tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec)
32orderedTupleAssocs :: RelationTuple -> [(AttributeName, Atom)]
33orderedTupleAssocs tup@(RelationTuple attrVec _) = map (\attr -> (attributeName attr, atomForAttr (attributeName attr))) oAttrs
34 where
35 oAttrs = orderedAttributes attrVec
36 atomForAttr nam = case atomForAttributeName nam tup of
37 Left _ -> TextAtom "<?>"
38 Right val -> val
40-- return atoms in some arbitrary but consistent key order
41tupleAtoms :: RelationTuple -> V.Vector Atom
42tupleAtoms (RelationTuple _ tupVec) = tupVec
44atomForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom
45atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of
46 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))
47 Just index -> case tupVec V.!? index of
48 Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))
49 Just atom -> Right atom
51atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> Either RelationalError (V.Vector Atom)
52atomsForAttributeNames attrNames tuple =
53 V.map (\index -> tupleAtoms tuple V.! index) <$> vectorIndicesForAttributeNames attrNames (tupleAttributes tuple)
55vectorIndicesForAttributeNames :: V.Vector AttributeName -> Attributes -> Either RelationalError (V.Vector Int)
56vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNames then
57 Left $ NoSuchAttributeNamesError (S.fromList (V.toList unknownAttrNames))
58 else
59 Right $ V.map mapper attrNameVec
60 where
61 unknownAttrNames = V.filter (`V.notElem` attributeNames attrs) attrNameVec
62 mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (V.map attributeName attrs))
65relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation
66relationForAttributeName attrName tuple = do
67 aType <- atomTypeForAttributeName attrName (tupleAttributes tuple)
68 if not (isRelationAtomType aType) then
69 Left $ AttributeIsNotRelationValuedError attrName
70 else do
71 atomVal <- atomForAttributeName attrName tuple
72 relationForAtom atomVal
74--in case the oldattr does not exist in the tuple, then return the old tuple
75tupleRenameAttribute :: AttributeName -> AttributeName -> RelationTuple -> RelationTuple
76tupleRenameAttribute oldattr newattr (RelationTuple tupAttrs tupVec) = RelationTuple newAttrs tupVec
77 where
78 newAttrs = renameAttributes oldattr newattr tupAttrs
80mkRelationTuple :: Attributes -> V.Vector Atom -> RelationTuple
81mkRelationTuple = RelationTuple
83mkRelationTuples :: Attributes -> [V.Vector Atom] -> [RelationTuple]
84mkRelationTuples attrs = map mapper
85 where
86 mapper = mkRelationTuple attrs
88mkRelationTupleFromMap :: M.Map AttributeName Atom -> RelationTuple
89mkRelationTupleFromMap attrMap = RelationTuple attrs (V.map (attrMap M.!) attrNames)
90 where
91 attrNames = V.fromList (M.keys attrMap)
92 attrs = V.map (\attrName -> Attribute attrName (atomTypeForAtom (attrMap M.! attrName))) attrNames
94--return error if attribute names match but their types do not
95singleTupleSetJoin :: Attributes -> RelationTuple -> RelationTupleSet -> Either RelationalError [RelationTuple]
96singleTupleSetJoin joinAttrs tup tupSet =
97 foldM tupleJoiner [] (asList tupSet)
98 where
99 tupleJoiner :: [RelationTuple] -> RelationTuple -> Either RelationalError [RelationTuple]
100 tupleJoiner accumulator tuple2 = case singleTupleJoin joinAttrs tup tuple2 of
101 Right Nothing -> Right accumulator
102 Right (Just relTuple) -> Right $ relTuple : accumulator
103 Left err -> Left err
105{-
106singleTupleSetJoin :: RelationTuple -> RelationTupleSet -> RelationTupleSet
107singleTupleSetJoin tup1 tupSet = HS.union
108 where
109 mapper tup2 = singleTupleJoin tup1 tup2
110-}
112-- if the keys share some keys and values, then merge the tuples
113-- if there are shared attributes, if they match, create a new tuple from the atoms of both tuples based on the attribute ordering argument
114singleTupleJoin :: Attributes -> RelationTuple -> RelationTuple -> Either RelationalError (Maybe RelationTuple)
115singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = if
116 V.null keysIntersection || atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2
117 then
118 return Nothing
119 else
120 return $ Just $ RelationTuple joinedAttrs newVec
121 where
122 keysIntersection = V.map attributeName attrsIntersection
123 attrsIntersection = V.filter (`V.elem` tupAttrs1) tupAttrs2
124 newVec = V.map (findAtomForAttributeName . attributeName) joinedAttrs
125 --search both tuples for the attribute
126 findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2]
128--same consideration as Data.List.union- duplicates in v1 are not de-duped
129vectorUnion :: (Eq a) => V.Vector a -> V.Vector a -> V.Vector a
130vectorUnion v1 v2 = V.foldr folder v1 v2
131 where
132 folder e acc = if V.elem e v1 then
133 acc
134 else
135 V.snoc acc e
137--precondition- no overlap in attributes
138tupleExtend :: RelationTuple -> RelationTuple -> RelationTuple
139tupleExtend (RelationTuple tupAttrs1 tupVec1) (RelationTuple tupAttrs2 tupVec2) = RelationTuple newAttrs newVec
140 where
141 newAttrs = tupAttrs1 V.++ tupAttrs2
142 newVec = tupVec1 V.++ tupVec2
144tupleAtomExtend :: AttributeName -> Atom -> RelationTuple -> RelationTuple
145tupleAtomExtend newAttrName atom tupIn = tupleExtend tupIn newTup
146 where
147 newTup = RelationTuple (V.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)
149--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)]
150tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple
151tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec
152 where
153 deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) attrs
154 indexDeleter = V.ifilter (\index _ -> V.notElem index deleteIndices)
155 newAttrs = indexDeleter attrs
156 newTupVec = indexDeleter tupVec
158--return the attributes and atoms which are equal in both vectors
159--semi-join
160tupleIntersection :: RelationTuple -> RelationTuple -> RelationTuple
161tupleIntersection tuple1 tuple2 = RelationTuple newAttrs newTupVec
162 where
163 attrs1 = tupleAttributes tuple1
164 attrs2 = tupleAttributes tuple2
165 matchingIndices = V.findIndices (\attr -> V.elem attr attrs2 &&
166 atomForAttributeName (attributeName attr) tuple1 ==
167 atomForAttributeName (attributeName attr) tuple2
168 ) attrs1
169 indexFilter = V.ifilter (\index _ -> V.elem index matchingIndices)
170 newAttrs = indexFilter attrs1
171 newTupVec = indexFilter (tupleAtoms tuple1)
173-- | An optimized form of tuple update which updates vectors efficiently.
174updateTupleWithAtoms :: M.Map AttributeName Atom -> RelationTuple -> RelationTuple
175updateTupleWithAtoms updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec
176 where
177 updateKeysSet = M.keysSet updateMap
178 updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs)
179 newVec = V.update tupVec updateVec
180 updateVec = V.map (\(index, attr) -> (index, updateMap M.! attributeName attr)) updateKeysIVec
182tupleToMap :: RelationTuple -> M.Map AttributeName Atom
183tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList
184 where
185 assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed attrs)
187verifyTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple
188verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs
189 tupleTypes = V.map atomTypeForAtom (tupleAtoms tuple) in
190 if V.length attrs /= V.length tupleTypes then
191 Left $ TupleAttributeCountMismatchError 0
192 else do
193 mapM_ (uncurry atomTypeVerify) (V.zip attrsTypes tupleTypes)
194 Right tuple
196--two tuples can be equal but the vectors of attributes could be out-of-order
197--reorder if necessary- this is useful during relMogrify so that all the relation's tuples have identical atom/attribute ordering
198reorderTuple :: Attributes -> RelationTuple -> RelationTuple
199reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then
200 tupIn
201 else
202 RelationTuple attrs (V.map mapper attrs)
203 where
204 mapper attr = case atomForAttributeName (attributeName attr) tupIn of
205 Left err -> error ("logic bug in reorderTuple: " ++ show err)
206 Right atom -> atom
208--used in Generics derivation for ADTs without named attributes
209trimTuple :: Int -> RelationTuple -> RelationTuple
210trimTuple index (RelationTuple attrs vals) = RelationTuple (V.drop index attrs) (V.drop index vals)