git.iko.soy/project-m36
on master help sign in
fix attribute-specific ordering bug in Tupleable

resolves #184

commita2b50edfd28d44f2b6fabce64fe815d303c9a557 authorAgentM <agentm@themactionfaction.com> dateSat 27 Jan 2018, 19:15 (9 years ago) parent51dbded
3 files changed+23−5
compare with master
unifiedsplit
src/lib/ProjectM36/Tuple.hs+1−1 src/lib/ProjectM36/Tupleable.hs+12−2 test/Relation/Tupleable.hs+10−2
src/lib/ProjectM36/Tuple.hs+1−1
@@ -209,7 +209,7 @@ reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then
209209 RelationTuple attrs (V.map mapper attrs)
210210 where
211211 mapper attr = case atomForAttributeName (attributeName attr) tupIn of
212− Left _ -> error "logic failure in reorderTuple"
212+ Left err -> error ("logic bug in reorderTuple: " ++ show err)
213213 Right atom -> atom
214214
215215--used in Generics derivation for ADTs without named attributes
src/lib/ProjectM36/Tupleable.hs+12−2
@@ -139,12 +139,14 @@ class TupleableG g where
139139 toTupleG :: g a -> RelationTuple
140140 toAttributesG :: g a -> Attributes
141141 fromTupleG :: RelationTuple -> Either RelationalError (g a)
142+ isRecordTypeG :: g a -> Bool
142143
143144--data type metadata
144145instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
145146 toTupleG (M1 v) = toTupleG v
146147 toAttributesG (M1 v) = toAttributesG v
147148 fromTupleG v = M1 <$> fromTupleG v
149+ isRecordTypeG (M1 v) = isRecordTypeG v
148150
149151--constructor metadata
150152instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
@@ -159,12 +161,19 @@ instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) whe
159161 atoms = V.fromList (toAtomsG v)
160162 toAttributesG (M1 v) = toAttributesG v
161163 fromTupleG tup = M1 <$> fromTupleG tup
164+ isRecordTypeG (M1 v) = isRecordTypeG v
162165
163166-- product types
164167instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
165168 toTupleG = error "toTupleG"
166169 toAttributesG ~(x :*: y) = toAttributesG x V.++ toAttributesG y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception
167− fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG (trimTuple 1 tup)
170+ fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG processedTuple
171+ where
172+ processedTuple = if isRecordTypeG (undefined :: a x) then
173+ tup
174+ else
175+ trimTuple 1 tup
176+ isRecordTypeG ~(x :*: y) = isRecordTypeG x || isRecordTypeG y
168177
169178--selector/record
170179instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
@@ -186,6 +195,7 @@ instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
186195 (atomTypeForAtom atom)
187196 )) Right (fromAtomG atom [atom])
188197 name = selName (undefined :: M1 S c a x)
198+ isRecordTypeG _ = not (null (selName (undefined :: M1 S c a x)))
189199
190200--constructors with no arguments
191201--basically useless but orthoganal to relationTrue
@@ -193,5 +203,5 @@ instance TupleableG U1 where
193203 toTupleG _= emptyTuple
194204 toAttributesG _ = emptyAttributes
195205 fromTupleG _ = pure U1
196−
206+ isRecordTypeG _ = False
197207
test/Relation/Tupleable.hs+10−2
@@ -83,7 +83,7 @@ main = do
8383 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
8484
8585testList :: Test
86−testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr]
86+testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple]
8787
8888testADT1 :: Test
8989testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example))
@@ -191,4 +191,12 @@ testDeleteExpr = TestCase $ do
191191 attr9C = 5.5}
192192 assertEqual "delete expr" expected actual
193193
194−
194+--discovered in #184 by ruhatch
195+testReorderedTuple :: Test
196+testReorderedTuple = TestCase $ do
197+ let tupleRev :: RelationTuple -> RelationTuple
198+ tupleRev (RelationTuple v1 v2) = RelationTuple (V.reverse v1) (V.reverse v2)
199+ expected = Test2C {attrB = 3,
200+ attrC = 4}
201+ actual = fromTuple . tupleRev . toTuple $ expected
202+ assertEqual "reordered tuple" (Right expected) actual