git.iko.soy/project-m36
on fbfa2ea help sign in
project-m36/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs
66 lines 4.8 kB history raw
1import TutorialD.Interpreter.TestBase
2import System.Exit
3import Test.HUnit
4import ProjectM36.Client
5import ProjectM36.Relation
6import qualified Data.Text as T
8main :: IO ()
9main = do
10 tcounts <- runTestTT (TestList [testBasicDBCFunction,
11 testErrorDBCFunction,
12 testExceptionDBCFunction,
13 testDBCFunctionWithAtomArguments
14 ])
15 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
17{-
18adddatabasecontextfunction "addtruerv" DatabaseContext -> DatabaseContext """(\[] ctx -> execState (evalDatabaseContextExpr (Assign "true2" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""
19-}
20testBasicDBCFunction :: Test
21testBasicDBCFunction = TestCase $ do
22 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
23 let addfunc = "adddatabasecontextfunction \"addTrue2\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] ctx -> executeDatabaseContextExpr (Assign \"true2\" (ExistingRelation relationTrue)) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""
24 executeTutorialD sess conn addfunc
25 executeTutorialD sess conn "execute addTrue2()"
26 let true2Expr = RelationVariable "true2" ()
27 result <- executeRelationalExpr sess conn true2Expr
28 assertEqual "simple atom function equality" (Right relationTrue) result
30testErrorDBCFunction :: Test
31testErrorDBCFunction = TestCase $ do
32 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
33 let addfunc = "adddatabasecontextfunction \"retErr\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] ctx -> Left (DatabaseContextFunctionUserError \"err\")) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""
34 executeTutorialD sess conn addfunc
35 expectTutorialDErr sess conn (T.isPrefixOf "DatabaseContextFunctionUserError (DatabaseContextFunctionUserError \"err\")") "execute retErr()"
37testExceptionDBCFunction :: Test
38testExceptionDBCFunction = TestCase $ do
39 -- throw an error, make sure it is caught- it might not be caught, for example, if the function is not forced
40 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
41 let addfunc = "adddatabasecontextfunction \"bomb\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] _ -> error \"boom\") :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""
42 executeTutorialD sess conn addfunc
43 expectTutorialDErr sess conn (\err -> "UnhandledExceptionError" `T.isPrefixOf` err) "execute bomb()"
46{-
47adddatabasecontextfunction "multiArgFunc" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> execState (evalDatabaseContextExpr (Assign "person" (MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", NakedAtomExpr name), ("age", NakedAtomExpr age)])]))) ctx)"""
48-}
49testDBCFunctionWithAtomArguments :: Test
50testDBCFunctionWithAtomArguments = TestCase $ do
51 --test function with creation of a relvar with some arguments
52 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
53 let addfunc = "adddatabasecontextfunction \"multiArgFunc\" Int -> Text -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\(age:name:_) ctx -> executeDatabaseContextExpr (Assign \"person\" (MakeRelationFromExprs Nothing [TupleExpr (fromList [(\"name\", NakedAtomExpr name), (\"age\", NakedAtomExpr age)])])) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""
54 executeTutorialD sess conn addfunc
55 executeTutorialD sess conn "execute multiArgFunc(30,\"Steve\")"
56 result <- executeRelationalExpr sess conn (RelationVariable "person" ())
57 let expectedPerson = mkRelationFromList (attributesFromList [Attribute "name" TextAtomType,
58 Attribute "age" IntAtomType]) [
59 [TextAtom "Steve", IntAtom 30]]
60 assertEqual "person relation" expectedPerson result
61 expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")"
63{-
64adddatabasecontextfunction "addperson" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> let newrel = MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", name),("age",age))]] in if isRight (runState (executeRelationalExpr (RelationVariable "person" ()) ctx)) then execState (executeContextExpr (Insert "person" newrel)) ctx else execState (executeContextExpr (Assign "person" newrel)) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""
65-}