git.iko.soy/project-m36
on 18f736a help sign in
project-m36/src/lib/ProjectM36/Tuple.hs
218 lines 11 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
51{- -- resolve naming clash with Attribute and Relation later
52atomTypeForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom
53atomTypeForAttributeName attrName tup = do
54 atom <- atomForAttributeName attrName tup
55 return $ atomTypeForAtom atom
56-}
58atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> Either RelationalError (V.Vector Atom)
59atomsForAttributeNames attrNames tuple = do
60 vindices <- vectorIndicesForAttributeNames attrNames (tupleAttributes tuple)
61 return $ V.map (\index -> tupleAtoms tuple V.! index) vindices
63vectorIndicesForAttributeNames :: V.Vector AttributeName -> Attributes -> Either RelationalError (V.Vector Int)
64vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNames then
65 Left $ NoSuchAttributeNamesError (S.fromList (V.toList unknownAttrNames))
66 else
67 Right $ V.map mapper attrNameVec
68 where
69 unknownAttrNames = V.filter (`V.notElem` attributeNames attrs) attrNameVec
70 mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (V.map attributeName attrs))
73relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation
74relationForAttributeName attrName tuple = do
75 aType <- atomTypeForAttributeName attrName (tupleAttributes tuple)
76 if not (isRelationAtomType aType) then
77 Left $ AttributeIsNotRelationValuedError attrName
78 else do
79 atomVal <- atomForAttributeName attrName tuple
80 relationForAtom atomVal
82--in case the oldattr does not exist in the tuple, then return the old tuple
83tupleRenameAttribute :: AttributeName -> AttributeName -> RelationTuple -> RelationTuple
84tupleRenameAttribute oldattr newattr (RelationTuple tupAttrs tupVec) = RelationTuple newAttrs tupVec
85 where
86 newAttrs = renameAttributes oldattr newattr tupAttrs
88mkRelationTuple :: Attributes -> V.Vector Atom -> RelationTuple
89mkRelationTuple = RelationTuple
91mkRelationTuples :: Attributes -> [V.Vector Atom] -> [RelationTuple]
92mkRelationTuples attrs = map mapper
93 where
94 mapper = mkRelationTuple attrs
96mkRelationTupleFromMap :: M.Map AttributeName Atom -> RelationTuple
97mkRelationTupleFromMap attrMap = RelationTuple attrs (V.map (\attrName -> attrMap M.! attrName) attrNames)
98 where
99 attrNames = V.fromList (M.keys attrMap)
100 attrs = V.map (\attrName -> Attribute attrName (atomTypeForAtom (attrMap M.! attrName))) attrNames
102--return error if attribute names match but their types do not
103singleTupleSetJoin :: Attributes -> RelationTuple -> RelationTupleSet -> Either RelationalError [RelationTuple]
104singleTupleSetJoin joinAttrs tup tupSet =
105 foldM tupleJoiner [] (asList tupSet)
106 where
107 tupleJoiner :: [RelationTuple] -> RelationTuple -> Either RelationalError [RelationTuple]
108 tupleJoiner accumulator tuple2 = case singleTupleJoin joinAttrs tup tuple2 of
109 Right Nothing -> Right accumulator
110 Right (Just relTuple) -> Right $ relTuple : accumulator
111 Left err -> Left err
113{-
114singleTupleSetJoin :: RelationTuple -> RelationTupleSet -> RelationTupleSet
115singleTupleSetJoin tup1 tupSet = HS.union
116 where
117 mapper tup2 = singleTupleJoin tup1 tup2
118-}
120-- if the keys share some keys and values, then merge the tuples
121-- if there are shared attributes, if they match, create a new tuple from the atoms of both tuples based on the attribute ordering argument
122singleTupleJoin :: Attributes -> RelationTuple -> RelationTuple -> Either RelationalError (Maybe RelationTuple)
123singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = if
124 V.null keysIntersection || atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2
125 then
126 return Nothing
127 else
128 return $ Just $ RelationTuple joinedAttrs newVec
129 where
130 keysIntersection = V.map attributeName attrsIntersection
131 attrsIntersection = V.filter (`V.elem` tupAttrs1) tupAttrs2
132 newVec = V.map (findAtomForAttributeName . attributeName) joinedAttrs
133 --search both tuples for the attribute
134 findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2]
136--same consideration as Data.List.union- duplicates in v1 are not de-duped
137vectorUnion :: (Eq a) => V.Vector a -> V.Vector a -> V.Vector a
138vectorUnion v1 v2 = V.foldr folder v1 v2
139 where
140 folder e acc = if V.elem e v1 then
141 acc
142 else
143 V.snoc acc e
145--precondition- no overlap in attributes
146tupleExtend :: RelationTuple -> RelationTuple -> RelationTuple
147tupleExtend (RelationTuple tupAttrs1 tupVec1) (RelationTuple tupAttrs2 tupVec2) = RelationTuple newAttrs newVec
148 where
149 newAttrs = tupAttrs1 V.++ tupAttrs2
150 newVec = tupVec1 V.++ tupVec2
152tupleAtomExtend :: AttributeName -> Atom -> RelationTuple -> RelationTuple
153tupleAtomExtend newAttrName atom tupIn = tupleExtend tupIn newTup
154 where
155 newTup = RelationTuple (V.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)
157--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)]
158tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple
159tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec
160 where
161 deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) attrs
162 indexDeleter = V.ifilter (\index _ -> V.notElem index deleteIndices)
163 newAttrs = indexDeleter attrs
164 newTupVec = indexDeleter tupVec
166--return the attributes and atoms which are equal in both vectors
167--semi-join
168tupleIntersection :: RelationTuple -> RelationTuple -> RelationTuple
169tupleIntersection tuple1 tuple2 = RelationTuple newAttrs newTupVec
170 where
171 attrs1 = tupleAttributes tuple1
172 attrs2 = tupleAttributes tuple2
173 matchingIndices = V.findIndices (\attr -> V.elem attr attrs2 &&
174 atomForAttributeName (attributeName attr) tuple1 ==
175 atomForAttributeName (attributeName attr) tuple2
176 ) attrs1
177 indexFilter = V.ifilter (\index _ -> V.elem index matchingIndices)
178 newAttrs = indexFilter attrs1
179 newTupVec = indexFilter (tupleAtoms tuple1)
181-- | An optimized form of tuple update which updates vectors efficiently.
182updateTupleWithAtoms :: M.Map AttributeName Atom -> RelationTuple -> RelationTuple
183updateTupleWithAtoms updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec
184 where
185 updateKeysSet = M.keysSet updateMap
186 updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs)
187 newVec = V.update tupVec updateVec
188 updateVec = V.map (\(index, attr) -> (index, updateMap M.! attributeName attr)) updateKeysIVec
190tupleToMap :: RelationTuple -> M.Map AttributeName Atom
191tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList
192 where
193 assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed attrs)
195verifyTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple
196verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs
197 tupleTypes = V.map atomTypeForAtom (tupleAtoms tuple) in
198 if V.length attrs /= V.length tupleTypes then
199 Left $ TupleAttributeCountMismatchError 0
200 else do
201 mapM_ (uncurry atomTypeVerify) (V.zip attrsTypes tupleTypes)
202 Right tuple
204--two tuples can be equal but the vectors of attributes could be out-of-order
205--reorder if necessary- this is useful during relMogrify so that all the relation's tuples have identical atom/attribute ordering
206reorderTuple :: Attributes -> RelationTuple -> RelationTuple
207reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then
208 tupIn
209 else
210 RelationTuple attrs (V.map mapper attrs)
211 where
212 mapper attr = case atomForAttributeName (attributeName attr) tupIn of
213 Left _ -> error "logic failure in reorderTuple"
214 Right atom -> atom
216--used in Generics derivation for ADTs without named attributes
217trimTuple :: Int -> RelationTuple -> RelationTuple
218trimTuple index (RelationTuple attrs vals) = RelationTuple (V.drop index attrs) (V.drop index vals)