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