1b68b23 · project-m36 · git.iko.soy

git.iko.soy/project-m36

do a better job of hiding Attributes implementation details

commit1b68b23e04366649ed6cea3983fba881ac48a279 authorAgentM <agentm@themactionfaction.com> dateSat 30 Jan 2021, 15:08 (6 years ago) parent7b9c340

7 files changed+95−50

compare with master

unifiedsplit

src/lib/ProjectM36/Attribute.hs+47−18 src/lib/ProjectM36/Base.hs+8−5 src/lib/ProjectM36/Relation.hs+12−14 src/lib/ProjectM36/Tuple.hs+11−6 src/lib/ProjectM36/TupleSet.hs+4−4 src/lib/ProjectM36/Tupleable.hs+1−2 test/Relation/Basic.hs+12−1

src/lib/ProjectM36/Attribute.hs+47−18

@@ -20,7 +20,10 @@ instance Semigroup Attributes where

2020 Right attrs' -> attrs'

2121

2222instance Monoid Attributes where

23− mempty = Attributes mempty mempty

23+ mempty = Attributes {

24+ attributesVec = mempty

25+ --,attributeSet = mempty

26+ }

2427

2528emptyAttributes :: Attributes

2629emptyAttributes = mempty

@@ -29,13 +32,19 @@ null :: Attributes -> Bool

2932null a = V.null (attributesVec a)

3033

3134singleton :: Attribute -> Attributes

32−singleton attr = Attributes (V.singleton attr) (HS.singleton attr)

35+singleton attr = Attributes {

36+ attributesVec = V.singleton attr

37+ --,attributesSet = HS.singleton attr

38+ }

3339

3440toList :: Attributes -> [Attribute]

3541toList attrs = V.toList (attributesVec attrs)

3642

3743attributesFromList :: [Attribute] -> Attributes

38−attributesFromList attrsL = Attributes vec hset

44+attributesFromList attrsL = Attributes {

45+ attributesVec = vec

46+ --,attributesSet = hset

47+ }

3948 where

4049 vec = if length attrsL == HS.size hset then

4150 --fast path- no duplicates

@@ -90,7 +99,10 @@ joinAttributes attrs1 attrs2 =

9099 nameSet1 = attributeNameSet attrs1

91100 nameSet2 = attributeNameSet attrs2

92101 overlappingNames = S.intersection nameSet1 nameSet2

93− concated f = Attributes (f (attributesVec attrs1 <> attributesVec attrs2)) (attributesSet attrs1 <> attributesSet attrs2)

102+ concated f = Attributes {

103+ attributesVec = f (attributesVec attrs1 <> attributesVec attrs2)

104+ --,attributesSet = attributesSet attrs1 <> attributesSet attrs2

105+ }

94106

95107addAttributes :: Attributes -> Attributes -> Attributes

96108addAttributes = (<>)

@@ -102,20 +114,22 @@ deleteAttributeName :: AttributeName -> Attributes -> Attributes

102114deleteAttributeName attrName attrs = deleteAttributeNames (S.singleton attrName) attrs

103115

104116deleteAttributeNames :: S.Set AttributeName -> Attributes -> Attributes

105−deleteAttributeNames attrNames attrs = Attributes vec hset

117+deleteAttributeNames attrNames attrs = Attributes {

118+ attributesVec = vec

119+ }

106120 where

107121 vec = V.filter attrFilter (attributesVec attrs)

108− hset = HS.filter attrFilter (attributesSet attrs)

109122 attrFilter attr = S.notMember (attributeName attr) attrNames

110123

111124renameAttribute :: AttributeName -> Attribute -> Attribute

112125renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo

113126

114127renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes

115−renameAttributes oldAttrName newAttrName attrs = Attributes vec hset

128+renameAttributes oldAttrName newAttrName attrs = Attributes {

129+ attributesVec = vec

130+ }

116131 where

117132 vec = V.map renamer (attributesVec attrs)

118− hset = HS.map renamer (attributesSet attrs)

119133 renamer attr = if attributeName attr == oldAttrName then

120134 renameAttribute newAttrName attr

121135 else

@@ -145,10 +159,11 @@ projectionAttributesForNames names attrsIn =

145159 missingNames = attributeNamesNotContained names (S.fromList (V.toList (attributeNames attrsIn)))

146160

147161attributesForNames :: S.Set AttributeName -> Attributes -> Attributes

148−attributesForNames attrNameSet attrs = Attributes vec hset

162+attributesForNames attrNameSet attrs = Attributes {

163+ attributesVec = vec

164+ }

149165 where

150166 vec = V.filter filt (attributesVec attrs)

151− hset = HS.filter filt (attributesSet attrs)

152167 filt attr = S.member (attributeName attr) attrNameSet

153168

154169attributeNameSet :: Attributes -> S.Set AttributeName

@@ -192,7 +207,10 @@ attributesDifference attrsA attrsB =

192207 if attributesSet attrsA == attributesSet attrsB then

193208 mempty

194209 else

195− Attributes vec hset

210+ Attributes {

211+ attributesVec = vec

212+ --,attributesSet = hset

213+ }

196214 where

197215 hset = HS.difference setA setB <> HS.difference setB setA

198216 setA = attributesSet attrsA

@@ -212,16 +230,19 @@ verifyAttributes attrs =

212230 where

213231 vecSet = V.foldr' HS.insert HS.empty (attributesVec attrs)

214232 diffSet = HS.difference vecSet (attributesSet attrs) <> HS.difference (attributesSet attrs) vecSet

215− diffAttrs = Attributes (V.fromList (HS.toList diffSet)) diffSet

233+ diffAttrs = Attributes {

234+ attributesVec = V.fromList (HS.toList diffSet)

235+ --,attributesSet = diffSet

236+ }

216237

217238--used in Generics derivation for ADTs without named attributes- not to be used elsewhere

218239--drop first n attributes from vector representation

219240drop :: Int -> Attributes -> Attributes

220−drop c attrs = Attributes vec hset

241+drop c attrs = Attributes { attributesVec = vec

242+ }

221243 where

222− droppedAttrs = V.take c (attributesVec attrs)

223244 vec = V.drop c (attributesVec attrs)

224− hset = HS.filter (`V.notElem` droppedAttrs) hset

245+

225246

226247-- use this in preference to attributesEqual when the attribute ordering matters such as during tuple unions

227248attributesAndOrderEqual :: Attributes -> Attributes -> Bool

@@ -229,7 +250,9 @@ attributesAndOrderEqual a b = attributesVec a == attributesVec b

229250

230251-- use to determine if the same attributes are contained (but ordering is irrelevant)

231252attributesEqual :: Attributes -> Attributes -> Bool

232−attributesEqual = (==)

253+attributesEqual attrsA attrsB =

254+ attributesVec attrsA == attributesVec attrsB ||

255+ attributesSet attrsA == attributesSet attrsB

233256

234257attributesAsMap :: Attributes -> M.Map AttributeName Attribute

235258attributesAsMap attrs = V.foldr' (\attr acc -> M.insert (attributeName attr) attr acc) mempty (attributesVec attrs)

@@ -237,13 +260,19 @@ attributesAsMap attrs = V.foldr' (\attr acc -> M.insert (attributeName attr) att

237260

238261-- | Left-biased union of attributes.

239262union :: Attributes -> Attributes -> Attributes

240−union attrsA attrsB = Attributes vec hset

263+union attrsA attrsB = Attributes {

264+ attributesVec = vec

265+ --,attributesSet = hset

266+ }

241267 where

242268 hset = HS.union (attributesSet attrsA) (attributesSet attrsB)

243269 vec = HS.foldr (flip V.snoc) mempty hset

244270

245271intersection :: Attributes -> Attributes -> Attributes

246−intersection attrsA attrsB = Attributes vec hset

272+intersection attrsA attrsB = Attributes {

273+ attributesVec = vec

274+ --,attributesSet = hset

275+ }

247276 where

248277 hset = HS.intersection (attributesSet attrsA) (attributesSet attrsB)

249278 vec = HS.foldr (flip V.snoc) mempty hset

src/lib/ProjectM36/Base.hs+8−5

@@ -103,13 +103,16 @@ type AttributesHash = Int

103103

104104-- | 'Attributes' represent the head of a relation.

105105data Attributes = Attributes {

106− attributesVec :: V.Vector Attribute,

107− attributesSet :: HS.HashSet Attribute

106+ attributesVec :: V.Vector Attribute

107+ --,attributesSet :: HS.HashSet Attribute --compare with this generated in heap profile and benchmarks

108108 }

109109 deriving (NFData, Read, Hashable, Generic)

110110

111+attributesSet :: Attributes -> HS.HashSet Attribute

112+attributesSet = HS.fromList . V.toList . attributesVec

113+

111114instance Show Attributes where

112− show attrs = "attributesFromList [" <> L.intercalate " " (map (\attr -> "(" <> show attr <> ")") (V.toList (attributesVec attrs))) <> "]"

115+ show attrs = "attributesFromList [" <> L.intercalate ", " (map (\attr -> "(" <> show attr <> ")") (V.toList (attributesVec attrs))) <> "]"

113116

114117--when attribute ordering is irrelevant

115118instance Eq Attributes where

@@ -118,7 +121,7 @@ instance Eq Attributes where

118121 attributesSet attrsA == attributesSet attrsB

119122

120123sortedAttributesIndices :: Attributes -> [(Int, Attribute)]

121−sortedAttributesIndices (Attributes attrs _) = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed attrs)

124+sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed (attributesVec attrs))

122125

123126-- | The relation's tuple set is the body of the relation.

124127newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Read)

@@ -155,7 +158,7 @@ instance Eq RelationTuple where

155158 tuple1@(RelationTuple attrs1 _) == tuple2@(RelationTuple attrs2 _) =

156159 attrs1 == attrs2 && atomsEqual

157160 where

158− atomForAttribute attr (RelationTuple (Attributes attrs _) tupVec) = case V.findIndex (== attr) attrs of

161+ atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) (attributesVec attrs) of

159162 Nothing -> Nothing

160163 Just index -> tupVec V.!? index

161164 atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) (attributesVec attrs1)

src/lib/ProjectM36/Relation.hs+12−14

@@ -17,8 +17,6 @@ import Data.Either (isRight)

1717import System.Random.Shuffle

1818import Control.Monad.Random

1919

20−--import Debug.Trace

21−

2220attributes :: Relation -> Attributes

2321attributes (Relation attrs _ ) = attrs

2422

@@ -35,7 +33,7 @@ atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType

3533atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs

3634

3735mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation

38−mkRelationFromList attrs atomMatrix =

36+mkRelationFromList attrs atomMatrix = do

3937 Relation attrs <$> mkTupleSetFromList attrs atomMatrix

4038

4139emptyRelationWithAttrs :: Attributes -> Relation

@@ -93,8 +91,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

9391project :: S.Set AttributeName -> Relation -> Either RelationalError Relation

9492project attrNames rel@(Relation _ tupSet) = do

9593 newAttrs <- A.projectionAttributesForNames attrNames (attributes rel)

96− let newAttrNameSet = A.attributeNameSet newAttrs

97− newTupleList = map (tupleProject newAttrNameSet) (asList tupSet)

94+ newTupleList <- mapM (tupleProject newAttrs) (asList tupSet)

9895 pure (Relation newAttrs (RelationTupleSet (HS.toList (HS.fromList newTupleList))))

9996

10097rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation

@@ -186,14 +183,13 @@ ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of

186183tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation

187184tupleUngroup relvalAttrName newAttrs tuple = do

188185 relvalRelation <- relationForAttributeName relvalAttrName tuple

186+ let nonGroupAttrs = A.intersection newAttrs (tupleAttributes tuple)

187+ nonGroupTupleProjection <- tupleProject nonGroupAttrs tuple

188+ let folder tupleIn acc = case acc of

189+ Left err -> Left err

190+ Right accRel ->

191+ union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])

189192 relFold folder (Right $ Relation newAttrs emptyTupleSet) relvalRelation

190− where

191− nonGroupTupleProjection = tupleProject nonGroupAttrNames tuple

192− nonGroupAttrNames = A.attributeNameSet (A.intersection newAttrs (tupleAttributes tuple))

193− folder tupleIn acc = case acc of

194− Left err -> Left err

195− Right accRel ->

196− union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])

197193

198194attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes

199195attributesForRelval relvalAttrName (Relation attrs _) = do

@@ -248,7 +244,8 @@ relMap mapper (Relation attrs tupleSet) =

248244

249245relMogrify :: (RelationTuple -> Either RelationalError RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation

250246relMogrify mapper newAttributes (Relation _ tupSet) = do

251− newTuples <- mapM mapper (asList tupSet)

247+ newTuples <- mapM (\tup ->

248+ reorderTuple newAttributes <$> mapper tup) (asList tupSet)

252249 mkRelationFromTuples newAttributes newTuples

253250

254251relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a

@@ -294,7 +291,8 @@ typesAsRelation types = mkRelationFromTuples attrs tuples

294291 dConsType = RelationAtomType subAttrs

295292 tuples = map mkTypeConsDescription types

296293

297− mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])

294+ mkTypeConsDescription (tCons, dConsList) =

295+ RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])

298296

299297 mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " (DCD.name dCons:map (T.pack . show) (DCD.fields dCons)))) dConsList of

300298 Left err -> error ("mkRelationFromTuples pooped " ++ show err)

src/lib/ProjectM36/Tuple.hs+11−6

@@ -14,8 +14,6 @@ import Control.Monad

1414import Control.Arrow

1515import Data.Maybe

1616

17−--import Debug.Trace

18−

1917emptyTuple :: RelationTuple

2018emptyTuple = RelationTuple mempty mempty

2119

@@ -148,8 +146,7 @@ tupleAtomExtend newAttrName atom tupIn = tupleExtend tupIn newTup

148146 where

149147 newTup = RelationTuple (A.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)

150148

151−--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)]

152−tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple

149+{-tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple

153150tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec

154151 where

155152 deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) (attributesVec attrs)

@@ -158,7 +155,14 @@ tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs

158155 Left err -> error (show (err, projectAttrs, attrs))

159156 Right attrs' -> attrs'

160157 newTupVec = indexDeleter tupVec

161−

158+-}

159+-- remember that the attributes order matters

160+tupleProject :: Attributes -> RelationTuple -> Either RelationalError RelationTuple

161+tupleProject projectAttrs tup = do

162+ newTupVec <- foldM (\acc attr ->

163+ V.snoc acc <$> atomForAttributeName (attributeName attr) tup

164+ ) V.empty (attributesVec projectAttrs)

165+ pure $ reorderTuple projectAttrs (RelationTuple projectAttrs newTupVec)

162166--return the attributes and atoms which are equal in both vectors

163167--semi-join

164168tupleIntersection :: RelationTuple -> RelationTuple -> RelationTuple

@@ -190,6 +194,7 @@ tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList

190194 where

191195 assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed (attributesVec attrs))

192196

197+-- | Validate that the tuple has the correct attributes in the correct order

193198verifyTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple

194199verifyTuple attrs tuple = let attrsTypes = A.atomTypes attrs

195200 tupleTypes = V.map atomTypeForAtom (tupleAtoms tuple) in

@@ -202,7 +207,7 @@ verifyTuple attrs tuple = let attrsTypes = A.atomTypes attrs

202207--two tuples can be equal but the vectors of attributes could be out-of-order

203208--reorder if necessary- this is useful during relMogrify so that all the relation's tuples have identical atom/attribute ordering

204209reorderTuple :: Attributes -> RelationTuple -> RelationTuple

205−reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then

210+reorderTuple attrs tupIn = if attributesAndOrderEqual (tupleAttributes tupIn) attrs then

206211 tupIn

207212 else

208213 RelationTuple attrs (V.map mapper (attributesVec attrs))

src/lib/ProjectM36/TupleSet.hs+4−4

@@ -7,8 +7,6 @@ import qualified Data.Vector as V

77import qualified Control.Parallel.Strategies as P

88import Data.Either

10−import Debug.Trace

11−

1210emptyTupleSet :: RelationTupleSet

1311emptyTupleSet = RelationTupleSet []

1412

@@ -35,6 +33,8 @@ mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationT

3533mkTupleSetFromList attrs atomMatrix = mkTupleSet attrs $ map (mkRelationTuple attrs . V.fromList) atomMatrix

3634

3735

38−-- | Target attributes must match the first tuple set.

36+-- | Union two tuplesets while reordering their attribute/atom mapping properly.

3937tupleSetUnion :: Attributes -> RelationTupleSet -> RelationTupleSet -> RelationTupleSet

40−tupleSetUnion targetAttrs tupSet1 tupSet2 = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple targetAttrs) (asList tupSet2)

38+tupleSetUnion targetAttrs tupSet1 tupSet2 = RelationTupleSet $ HS.toList . HS.fromList $ reorder (asList tupSet1) ++ reorder (asList tupSet2)

39+ where

40+ reorder = map (reorderTuple targetAttrs)

src/lib/ProjectM36/Tupleable.hs+1−2

@@ -45,7 +45,6 @@ import ProjectM36.Error

4545import ProjectM36.Tuple

4646import ProjectM36.TupleSet

4747import qualified Data.Set as S

48−import qualified Data.HashSet as HS

4948

5049{-import Data.Binary

5150import Control.DeepSeq

@@ -230,7 +229,7 @@ instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) whe

230229 where

231230 attrsToCheck = toAttributesG opts v

232231 counter = V.generate (arity attrsToCheck) id

233− attrs = Attributes attrsV (HS.fromList (V.toList attrsV))

232+ attrs = attributesFromList (V.toList attrsV)

234233 attrsV = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then

235234 Attribute ("attr" <> T.pack (show (num + 1))) typ

236235 else

test/Relation/Basic.hs+12−1

@@ -23,7 +23,8 @@ testList = TestList [testRelation "relationTrue" relationTrue, testRelation "rel

2323 testRelation "products" productsRel,

2424 testRelation "supplierProducts" supplierProductsRel,

2525 testMkRelationFromExprsBadAttrs,

26− testExistingRelationType

26+ testExistingRelationType,

27+ testReorderTuple

2728 ]

2829

2930main :: IO ()

@@ -106,3 +107,13 @@ testExistingRelationType = TestCase $ do

106107 let typeResult = runRelationalExprM reenv (typeForRelationalExpr (ExistingRelation relationTrue))

107108 reenv = mkRelationalExprEnv dateExamples graph

108109 assertEqual "ExistingRelation with tuples type" (Right relationFalse) typeResult

110+

111+-- | Ensure that tuple reordering honors the

112+testReorderTuple :: Test

113+testReorderTuple = TestCase $ do

114+ let tup1 = mkRelationTuple attrs1 (V.fromList [IntAtom 4, TextAtom "test"])

115+ attrs1 = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" TextAtomType]

116+ attrs2 = A.attributesFromList [Attribute "b" TextAtomType, Attribute "a" IntAtomType]

117+ actual = reorderTuple attrs2 tup1

118+ expected = mkRelationTuple attrs2 (V.fromList [TextAtom "test", IntAtom 4])

119+ assertEqual "reorderTuple" expected actual