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