a3402fc · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

properly handle more than two fields in product types

a3402fcAgentM7 years ago

src/lib/ProjectM36/Atomable.hs+5−6

compare with master

unifiedsplit

@@ -271,12 +271,11 @@ instance AtomableG U1 where

271

272-- product types

273instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where

274− toAtomG = error "invalid toAtomG in :*:"

274+ toAtomG = undefined

275− fromAtomG atom args = (:*:) <$> fromAtomG atom [headatom args] <*> fromAtomG atom (tailatoms args)

275+ fromAtomG atom args = (:*:) <$> fromAtomG atom splitargs1 <*> fromAtomG atom splitargs2

276− where headatom (x:_) = x

276+ where splitargs1 = take splitpoint args

277− headatom [] = error "no more atoms in head for product!"

277+ splitargs2 = drop splitpoint args

278− tailatoms (_:xs) = xs

278+ splitpoint = length args `div` 2

279− tailatoms [] = error "no more atoms in tail for product!"

280 toAtomTypeG = error "invalid toAtomTypeG in :*:"

279 toAtomTypeG = error "invalid toAtomTypeG in :*:"

281 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y

280 toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y

282 toAddTypeExprG = error "invalid toAddTypeExprG in :*:"

281 toAddTypeExprG = error "invalid toAddTypeExprG in :*:"

test/Relation/Atomable.hs+28−2

@@ -52,14 +52,30 @@ data User = User

52 { userFirstName :: Text

53 , userLastName :: Text

54 } deriving (Eq, Ord, Show, Generic, NFData, Binary, Atomable)

55−

55+

56+data Test9_4T = Test9_4C {

57+ f9_41 :: Int,

58+ f9_42 :: Int,

59+ f9_43 :: Int,

60+ f9_44 :: Int }

61+ deriving (Show, Generic, Eq, Binary, NFData, Atomable)

62+

63+data Test9_5T = Test9_5C {

64+ f9_51 :: Int,

65+ f9_52 :: Int,

66+ f9_53 :: Int,

67+ f9_54 :: Int,

68+ f9_55 :: Int

69+ }

70+ deriving (Show, Generic, Eq, Binary, NFData, Atomable)

71+

56main :: IO ()

72main :: IO ()

57main = do

73main = do

58 tcounts <- runTestTT testList

74 tcounts <- runTestTT testList

59 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

75 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

61testList :: Test

77testList :: Test

62−testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues, testRecordType]

78+testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues, testRecordType, testManyFields]

64-- test some basic data types like int, day, etc.

80-- test some basic data types like int, day, etc.

65testBasicMarshaling :: Test

81testBasicMarshaling :: Test

@@ -163,3 +179,13 @@ testRecordType = TestCase $ do

163 let expected = AddTypeConstructor (ADTypeConstructorDef "User" []) [DataConstructorDef "User" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType),DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType)]]

179 let expected = AddTypeConstructor (ADTypeConstructorDef "User" []) [DataConstructorDef "User" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType),DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType)]]

164

180

165 assertEqual "User record to database context expr" expected (toAddTypeExpr (Proxy :: Proxy User))

181 assertEqual "User record to database context expr" expected (toAddTypeExpr (Proxy :: Proxy User))

182+

183+--test both odd and even product types with more than 2 fields

184+testManyFields :: Test

185+testManyFields = TestCase $ do

186+ let example4 = Test9_4C 1 2 3 4

187+ assertEqual "four fields product type" example4 (fromAtom (toAtom example4))

188+

189+ let example5 = Test9_5C 1 2 3 4 5

190+ assertEqual "five fields product type" example5 (fromAtom (toAtom example5))

191+