git.iko.soy/project-m36
on 52182bc help sign in
project-m36/test/Relation/Basic.hs
112 lines 5.7 kB history raw
1import Test.HUnit
2import ProjectM36.Base
3import ProjectM36.Relation
4import ProjectM36.Error
5import ProjectM36.DateExamples
6import ProjectM36.TupleSet
7import ProjectM36.Attribute hiding (null, attributeNames)
8import ProjectM36.DataTypes.Primitive
9import ProjectM36.RelationalExpression
10import ProjectM36.Tuple
11import qualified ProjectM36.DatabaseContext as DBC
12import Control.Monad.Trans.Reader
13import qualified ProjectM36.Attribute as A
14import qualified Data.Map as M
15import qualified Data.Vector as V
16import qualified Data.Set as S
17import System.Exit
20testList :: Test
21testList = TestList [testRelation "relationTrue" relationTrue, testRelation "relationFalse" relationFalse,
22 testMkRelation1,
23 testRename1, testRename2,
24 testRelation "suppliers" suppliersRel,
25 testRelation "products" productsRel,
26 testRelation "supplierProducts" supplierProductsRel,
27 testMkRelationFromExprsBadAttrs,
28 testDuplicateAttributes,
29 testExistingRelationType
30 ]
32main :: IO ()
33main = do
34 tcounts <- runTestTT testList
35 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
37testRelation :: String -> Relation -> Test
38testRelation testName rel = TestCase $ assertEqual testName relationValidation (Right rel)
39 where
40 relationValidation = validateRelation rel
42-- run common relation checks
43validateRelation :: Relation -> Either RelationalError Relation
44validateRelation rel = do
45 _ <- validateAttrNamesMatchTupleAttrNames rel
46 validateAttrTypesMatchTupleAttrTypes rel
48validateAttrNamesMatchTupleAttrNames :: Relation -> Either RelationalError Relation
49validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupSet)
50 | null invalidSet = Right rel
51 | otherwise = Left $ AttributeNamesMismatchError S.empty
52 where
53 nameCheck tuple = attributeNames rel == tupleAttributeNameSet tuple
54 invalidSet = filter (not . nameCheck) (asList tupSet)
56validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation
57validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = foldr (\tuple acc ->
58 if tupleAttributes tuple == attrs && tupleAtomCheck tuple then
59 acc
60 else
61 Left $ TupleAttributeTypeMismatchError A.emptyAttributes
62 ) (Right rel) (asList tupSet)
63 where
64 tupleAtomCheck tuple = V.all (== True) (attrChecks tuple)
65 attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of
66 Left _ -> False
67 Right atom -> (Right $ atomTypeForAtom atom) ==
68 A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel)
70simpleRel :: Relation
71simpleRel = case mkRelation attrs tupleSet of
72 Right rel -> rel
73 Left _ -> undefined
74 where
75 attrs = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" TextAtomType]
76 tupleSet = RelationTupleSet [mkRelationTuple attrs (V.fromList [TextAtom "spam", TextAtom "spam2"])]
78--rename tests
79testRename1 :: Test
80testRename1 = TestCase $ assertEqual "attribute invalid" (rename "a" "b" relationTrue) (Left $ AttributeNamesMismatchError (S.singleton "a"))
82testRename2 :: Test
83testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRel) (Left $ AttributeNameInUseError "a")
85--mkRelation tests
86--test tupleset key mismatch failure
87testMkRelation1 :: Test
88testMkRelation1 = TestCase $ assertEqual "key mismatch" expectedError (mkRelation testAttrs testTupSet) -- the error attribute set is empty due to an optimization- the tuple attrs do not match the atoms' types
89 where
90 expectedError = Left (AtomTypeMismatchError TextAtomType IntAtomType)
91 testAttrs = A.attributesFromList [Attribute "a" TextAtomType]
92 testTupSet = RelationTupleSet [mkRelationTuple testAttrs $ V.fromList [TextAtom "v"],
93 mkRelationTuple testAttrs $ V.fromList [IntAtom 2]]
95testMkRelationFromExprsBadAttrs :: Test
96testMkRelationFromExprsBadAttrs = TestCase $ do
97 let context = DBC.empty
98 case runReader (evalRelationalExpr (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "badAttr1" (PrimitiveTypeConstructor "Int" IntAtomType) ()]) [TupleExpr (M.singleton "badAttr2" (NakedAtomExpr (IntAtom 1)))])) (mkRelationalExprState context) of
99 Left err -> assertEqual "tuple type mismatch" (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "badAttr2" IntAtomType])) err
100 Right _ -> assertFailure "expected tuple type mismatch"
102--creating an empty relation with duplicate attribute names should fail
103testDuplicateAttributes :: Test
104testDuplicateAttributes = TestCase $ do
105 let eRel = mkRelation attrs emptyTupleSet
106 attrs = attributesFromList [Attribute "a" IntAtomType, Attribute "a" TextAtomType]
107 assertEqual "duplicate attribute names" (Left (DuplicateAttributeNamesError (S.singleton "a"))) eRel
109testExistingRelationType :: Test
110testExistingRelationType = TestCase $ do
111 let typeResult = runReader (typeForRelationalExpr (ExistingRelation relationTrue)) (RelationalExprStateElems DBC.empty)
112 assertEqual "ExistingRelation with tuples type" (Right relationFalse) typeResult