git.iko.soy/project-m36
on 52182bc help sign in
project-m36/test/Relation/Tupleable.hs
202 lines 8.3 kB history raw
1{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts, TypeOperators, DeriveAnyClass #-}
2import Test.HUnit
3import ProjectM36.Tupleable
4import ProjectM36.Atomable
5import ProjectM36.Attribute
6import ProjectM36.Error
7import Data.Binary
8import ProjectM36.Base
9import Control.DeepSeq (NFData)
10import GHC.Generics
11import qualified Data.Vector as V
12import qualified Data.Map as M
13import qualified Data.Text as T
14import qualified Data.Set as S
15import System.Exit
16import Data.Proxy
18{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}
20data Test1T = Test1C {
21 attrA :: Integer
22 }
23 deriving (Generic, Eq, Show)
25data Test2T = Test2C {
26 attrB :: Integer,
27 attrC :: Integer
28 }
29 deriving (Generic, Eq, Show)
31data Test3T = Test3C Integer
32 deriving (Generic, Eq, Show)
34data Test4T = Test4C
35 deriving (Generic, Eq, Show)
37data Test5T = Test5C1 Integer |
38 Test5C2 Integer
39 deriving (Generic, Eq, Show)
41data Test6T = Test6C T.Text Integer Double
42 deriving (Generic, Eq, Show)
44data Test7A = Test7AC Integer
45 deriving (Generic, Show, Eq, Binary, NFData, Atomable)
48data Test7T = Test7C Test7A
49 deriving (Generic, Show, Eq)
51data Test8T = Test8C
52 deriving (Generic, Show, Eq)
54data Test9T = Test9C
55 {
56 attr9A :: Integer,
57 attr9B :: T.Text,
58 attr9C :: Double
59 }
60 deriving (Generic, Show, Eq)
62instance Tupleable Test1T
64instance Tupleable Test2T
66instance Tupleable Test3T
68instance Tupleable Test4T
70--instance Tupleable Test5T -- should fail at compile time- sum types not supported
72instance Tupleable Test6T
74instance Tupleable Test7T
76instance Tupleable Test8T
78instance Tupleable Test9T
80main :: IO ()
81main = do
82 tcounts <- runTestTT testList
83 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
85testList :: Test
86testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple]
88testADT1 :: Test
89testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example))
90 where
91 example = Test1C {attrA = 3}
93testADT2 :: Test
94testADT2 = TestCase $ do
95 let example = Test2C { attrB = 4, attrC = 6 }
96 assertEqual "two record constructor" (Right example) (fromTuple (toTuple example))
97 --this was a tricky case that was throwing the undefined exception because of insufficient laziness in the :*: matching- see ProjectM36.Tupleable
98 let expectedAttributes = attributesFromList [Attribute "attrB" IntegerAtomType,
99 Attribute "attrC" IntegerAtomType]
100 assertEqual "two record constructor toAttributes" expectedAttributes (toAttributes (Proxy :: Proxy Test2T))
103testADT3 :: Test
104testADT3 = TestCase $ assertEqual "one arg constructor" (Right example) (fromTuple (toTuple example))
105 where
106 example = Test3C 4
108testADT4 :: Test
109testADT4 = TestCase $ assertEqual "zero arg constructor" (Right example) (fromTuple (toTuple example))
110 where
111 example = Test4C
113--testADT5 should not compile
115testADT6 :: Test
116testADT6 = TestCase $ assertEqual "mixed types" (Right example) (fromTuple (toTuple example))
117 where
118 example = Test6C "testo" 3 4.0
120testADT7 :: Test
121testADT7 = TestCase $ do
122 let example = Test7C (Test7AC 3)
123 assertEqual "atom type" (Right example) (fromTuple (toTuple example))
124 let expectedAttrs = V.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))
125 assertEqual "adt atomtype" expectedAttrs (toAttributes (Proxy :: Proxy Test7T))
127testADT8 :: Test
128testADT8 = TestCase $ assertEqual "single value" (Right example) (fromTuple (toTuple example))
129 where
130 example = Test8C
132testInsertExpr :: Test
133testInsertExpr = TestCase $ assertEqual "insert expr" expected (toInsertExpr [Test9C {
134 attr9A = 4,
135 attr9B = "a",
136 attr9C = 3.4}] "rv")
137 where expected = Right (Insert "rv" (MakeStaticRelation attrs tuples))
138 attrs = attributesFromList [Attribute "attr9A" IntegerAtomType,
139 Attribute "attr9B" TextAtomType,
140 Attribute "attr9C" DoubleAtomType]
141 tuples = RelationTupleSet [RelationTuple attrs (V.fromList [IntegerAtom 4,
142 TextAtom "a",
143 DoubleAtom 3.4])]
145testDefineExpr :: Test
146testDefineExpr = TestCase $ assertEqual "define expr" expected actual
147 where
148 expected = Define "rv" (map NakedAttributeExpr attrs)
149 attrs = [Attribute "attr9A" IntegerAtomType,
150 Attribute "attr9B" TextAtomType,
151 Attribute "attr9C" DoubleAtomType]
152 actual = toDefineExpr (Proxy :: Proxy Test9T) "rv"
154testUpdateExpr :: Test
155testUpdateExpr = TestCase $ do
156 let expected = Right (Update "rv" updateMap restriction)
157 updateMap = M.fromList [("attr9B", NakedAtomExpr (TextAtom "b")),
158 ("attr9C", NakedAtomExpr (DoubleAtom 5.5))]
159 restriction = AttributeEqualityPredicate "attr9A" (NakedAtomExpr (IntegerAtom 5))
160 actual = toUpdateExpr "rv" ["attr9A"] Test9C {attr9A = 5,
161 attr9B = "b",
162 attr9C = 5.5}
164 assertEqual "update expr1" expected actual
166testUpdateExprEmptyAttrs :: Test
167testUpdateExprEmptyAttrs = TestCase $ do
168 let expected = Left EmptyAttributesError
169 actual = toUpdateExpr "rv" [] Test9C {attr9A = 5,
170 attr9B = "b",
171 attr9C = 5.5}
172 assertEqual "update with empty attrs" expected actual
174testUpdateExprWrongAttr :: Test
175testUpdateExprWrongAttr = TestCase $ do
176 --currently, passing in the wrong attribute replaces the whole relvar with a single tuple- is this what we want?
177 let expected = Left (NoSuchAttributeNamesError (S.singleton "nonexistentattr"))
178 actual = toUpdateExpr "rv" ["nonexistentattr"] Test9C {attr9A = 5,
179 attr9B = "b",
180 attr9C = 5.5}
181 assertEqual "update with wrong attr" expected actual
183testDeleteExpr :: Test
184testDeleteExpr = TestCase $ do
185 let expected = Right (Delete "rv" (AndPredicate (AttributeEqualityPredicate "attr9A"
186 (NakedAtomExpr (IntegerAtom 5)))
187 (AttributeEqualityPredicate "attr9B"
188 (NakedAtomExpr (TextAtom "b")))))
189 actual = toDeleteExpr "rv" ["attr9A", "attr9B"] Test9C {attr9A = 5,
190 attr9B = "b",
191 attr9C = 5.5}
192 assertEqual "delete expr" expected actual
194--discovered in #184 by ruhatch
195testReorderedTuple :: Test
196testReorderedTuple = 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