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