import Test.HUnit import ProjectM36.Base import ProjectM36.Relation import ProjectM36.Error import ProjectM36.DateExamples import ProjectM36.TupleSet import ProjectM36.Attribute hiding (null, attributeNames) import ProjectM36.DataTypes.Primitive import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph import ProjectM36.Tuple import qualified ProjectM36.DatabaseContext as DBC import qualified ProjectM36.Attribute as A import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.Set as S import System.Exit testList :: Test testList = TestList [testRelation "relationTrue" relationTrue, testRelation "relationFalse" relationFalse, testMkRelation1, testRename1, testRename2, testRelation "suppliers" suppliersRel, testRelation "products" productsRel, testRelation "supplierProducts" supplierProductsRel, testMkRelationFromExprsBadAttrs, testDuplicateAttributes, testExistingRelationType ] main :: IO () main = do tcounts <- runTestTT testList if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess testRelation :: String -> Relation -> Test testRelation testName rel = TestCase $ assertEqual testName relationValidation (Right rel) where relationValidation = validateRelation rel -- run common relation checks validateRelation :: Relation -> Either RelationalError Relation validateRelation rel = do _ <- validateAttrNamesMatchTupleAttrNames rel validateAttrTypesMatchTupleAttrTypes rel validateAttrNamesMatchTupleAttrNames :: Relation -> Either RelationalError Relation validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupSet) | null invalidSet = Right rel | otherwise = Left $ AttributeNamesMismatchError S.empty where nameCheck tuple = attributeNames rel == tupleAttributeNameSet tuple invalidSet = filter (not . nameCheck) (asList tupSet) validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = foldr (\tuple acc -> if tupleAttributes tuple == attrs && tupleAtomCheck tuple then acc else Left $ TupleAttributeTypeMismatchError A.emptyAttributes ) (Right rel) (asList tupSet) where tupleAtomCheck tuple = V.all (== True) (attrChecks tuple) attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of Left _ -> False Right atom -> Right (atomTypeForAtom atom) == A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel) simpleRel :: Relation simpleRel = case mkRelation attrs tupleSet of Right rel -> rel Left _ -> undefined where attrs = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" TextAtomType] tupleSet = RelationTupleSet [mkRelationTuple attrs (V.fromList [TextAtom "spam", TextAtom "spam2"])] --rename tests testRename1 :: Test testRename1 = TestCase $ assertEqual "attribute invalid" (rename "a" "b" relationTrue) (Left $ AttributeNamesMismatchError (S.singleton "a")) testRename2 :: Test testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRel) (Left $ AttributeNameInUseError "a") --mkRelation tests --test tupleset key mismatch failure testMkRelation1 :: Test testMkRelation1 = 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 where expectedError = Left (AtomTypeMismatchError TextAtomType IntAtomType) testAttrs = A.attributesFromList [Attribute "a" TextAtomType] testTupSet = RelationTupleSet [mkRelationTuple testAttrs $ V.fromList [TextAtom "v"], mkRelationTuple testAttrs $ V.fromList [IntAtom 2]] testMkRelationFromExprsBadAttrs :: Test testMkRelationFromExprsBadAttrs = TestCase $ do let context = DBC.empty (graph,_) <- freshTransactionGraph context let reenv = mkRelationalExprEnv context graph reExpr = MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "badAttr1" (PrimitiveTypeConstructor "Int" IntAtomType) ()]) (TupleExprs () [TupleExpr (M.singleton "badAttr2" (NakedAtomExpr (IntAtom 1)))]) evald = runRelationalExprM reenv (evalRelationalExpr reExpr) case evald of Left err -> assertEqual "tuple type mismatch" (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "badAttr2" IntAtomType])) err Right _ -> assertFailure "expected tuple type mismatch" --creating an empty relation with duplicate attribute names should fail testDuplicateAttributes :: Test testDuplicateAttributes = TestCase $ do let eRel = mkRelation attrs emptyTupleSet attrs = attributesFromList [Attribute "a" IntAtomType, Attribute "a" TextAtomType] assertEqual "duplicate attribute names" (Left (DuplicateAttributeNamesError (S.singleton "a"))) eRel testExistingRelationType :: Test testExistingRelationType = TestCase $ do (graph, _) <- freshTransactionGraph dateExamples let typeResult = runRelationalExprM reenv (typeForRelationalExpr (ExistingRelation relationTrue)) reenv = mkRelationalExprEnv dateExamples graph assertEqual "ExistingRelation with tuples type" (Right relationFalse) typeResult