git.iko.soy/project-m36
on fbfa2ea help sign in
project-m36/test/TutorialD/Interpreter/AtomFunctionScript.hs
115 lines 7.0 kB history raw
1import TutorialD.Interpreter.TestBase
2import System.Exit
3import Test.HUnit
4import ProjectM36.Client
5import ProjectM36.Relation
6import ProjectM36.Error
7import ProjectM36.DataTypes.Maybe
8import qualified Data.Vector as V
9import qualified Data.Map as M
11{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
12main :: IO ()
13main = do
14 tcounts <- runTestTT (TestList [testBasicAtomFunction,
15 testExceptionAtomFunction,
16 testErrorAtomFunction,
17 testNoArgumentAtomFunction,
18 testArgumentTypeMismatch,
19 testPolymorphicReturnType,
20 testScriptedTypeVariable
21 ])
22 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
24--add an atom function and run it
25testBasicAtomFunction :: Test
26testBasicAtomFunction = TestCase $ do
27 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
28 executeTutorialD sess conn "addatomfunction \"mkTest\" Int -> Either AtomFunctionError Int \"(\\\\(IntAtom x:xs) -> pure (IntAtom x)) :: [Atom] -> Either AtomFunctionError Atom\""
29 let attrs = [Attribute "x" IntAtomType]
30 funcAtomExpr = FunctionAtomExpr "mkTest" [NakedAtomExpr (IntAtom 3)] ()
31 tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]
32 expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 3]]
33 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)
35 assertEqual "simple atom function equality" expectedResult result
37--add an atom function which bombs out
38testExceptionAtomFunction :: Test
39testExceptionAtomFunction = TestCase $ do
40 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
41 executeTutorialD sess conn "addatomfunction \"mkTest\" Int -> Either AtomFunctionError Int \"\"\"(\\(IntAtom x:xs) -> (error (show 1))) :: [Atom] -> Either AtomFunctionError Atom\"\"\""
42 let attrs = [Attribute "x" IntAtomType]
43 funcAtomExpr = FunctionAtomExpr "mkTest" [NakedAtomExpr (IntAtom 3)] ()
44 tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]
45 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)
46 assertBool "catch error exception from script" (case result of
47 Left (UnhandledExceptionError _) -> True
48 _ -> False)
50testErrorAtomFunction :: Test
51testErrorAtomFunction = TestCase $ do
52 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
53 executeTutorialD sess conn "addatomfunction \"errorAtom\" Int -> Either AtomFunctionError Int \"\"\"(\\(IntAtom x:xs) -> Left (AtomFunctionUserError \"user\")) :: [Atom] -> Either AtomFunctionError Atom\"\"\""
55testNoArgumentAtomFunction :: Test
56testNoArgumentAtomFunction = TestCase $ do
57 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
58 executeTutorialD sess conn "addatomfunction \"mkTest\" Either AtomFunctionError Int \"\"\"(\\x -> pure (IntAtom 5)) :: [Atom] -> Either AtomFunctionError Atom\"\"\""
59 let attrs = [Attribute "x" IntAtomType]
60 funcAtomExpr = FunctionAtomExpr "mkTest" [] ()
61 tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]
62 expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 5]]
63 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)
64 assertEqual "no argument scripted function" expectedResult result
66testArgumentTypeMismatch :: Test
67testArgumentTypeMismatch = TestCase $ do
68 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
69 executeTutorialD sess conn "addatomfunction \"mkTest\" Int -> Either AtomFunctionError Int \"\"\"(\\(IntAtom x:_) -> pure $ TextAtom \"wrong type\") :: [Atom] -> Either AtomFunctionError Atom\"\"\""
70 let tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]
71 funcAtomExpr = FunctionAtomExpr "mkTest" [NakedAtomExpr (IntAtom 3)] ()
72 attrs = [Attribute "x" IntAtomType]
73 expectedResult = Left (AtomTypeMismatchError IntAtomType TextAtomType)
74 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)
75 assertEqual "type mismatch not detected" expectedResult result
77testPolymorphicReturnType :: Test
78testPolymorphicReturnType = TestCase $ do
79 --test that polymorphic function return type resolves to concrete type using fromMaybe builtin atom function
80 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
81 let funcAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntAtom 5),
82 NakedAtomExpr maybeAtom] ()
83 maybeAtom = ConstructedAtom "Just" (maybeAtomType IntAtomType) [IntAtom 3]
84 relExpr = MakeRelationFromExprs Nothing [TupleExpr (M.singleton "x" funcAtomExpr)]
85 mRelType <- typeForRelationalExpr sess conn relExpr
86 case mRelType of
87 Left err -> assertFailure (show err)
88 Right relType -> do
89 let expectedRetAttrs = V.fromList [Attribute "x" IntAtomType]
90 assertEqual "fromMaybe type" expectedRetAttrs (attributes relType)
91 mRes <- executeRelationalExpr sess conn relExpr
92 let expectedRel = mkRelationFromList (V.fromList [Attribute "x" IntAtomType]) [[IntAtom 3]]
93 assertEqual "fromMaybe result" expectedRel mRes
94 --test that type mismatch occurs for different types appearing in same type variable
95 let failFuncAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntAtom 5),
96 NakedAtomExpr mismatchAtom] ()
97 mismatchAtom = ConstructedAtom "Just" (maybeAtomType TextAtomType) [TextAtom "fail"]
98 failRelExpr = MakeRelationFromExprs Nothing [TupleExpr (M.singleton "x" failFuncAtomExpr)]
99 mFailRes <- executeRelationalExpr sess conn failRelExpr
100 let expectedErr = Left (AtomFunctionTypeVariableMismatch "a" IntAtomType TextAtomType)
101 assertEqual "expected type variable mismatch" expectedErr mFailRes
103--test that a user can create a function with a type variable argument
104testScriptedTypeVariable :: Test
105testScriptedTypeVariable = TestCase $ do
106 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
107 executeTutorialD sess conn "addatomfunction \"idTest\" a -> Either AtomFunctionError a \"(\\\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom\""
108 let attrs = [Attribute "x" IntAtomType]
109 funcAtomExpr = FunctionAtomExpr "idTest" [NakedAtomExpr (IntAtom 3)] ()
110 tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]
111 expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 3]]
112 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)
114 assertEqual "id function equality" expectedResult result