0d4a061 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

fix atom function atom type validation

0d4a061AgentM8 years ago

src/lib/ProjectM36/IsomorphicSchema.hs−1

compare with master

unifiedsplit

@@ -14,7 +14,6 @@ import Data.Binary

14import qualified Data.Map as M

15import qualified Data.Set as S

16import qualified Data.List as L

17−import qualified Data.Text as T

18import Data.Monoid

17import Data.Monoid

19-- isomorphic schemas offer bi-directional functors between two schemas

18-- isomorphic schemas offer bi-directional functors between two schemas

src/lib/ProjectM36/RelationalExpression.hs+10−8

@@ -753,18 +753,18 @@ predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do

753 --merge attrs into the state attributes

754 rstate <- ask

755 runExceptT $ do

756− aType <- liftE (typeFromAtomExpr attrs atomExpr)

756+ aType <- liftE (typeFromAtomExpr attrs atomExpr)

757 if aType /= BoolAtomType then

758 throwE (AtomTypeMismatchError aType BoolAtomType)

759 else

760 pure (\tupleIn ->

761− pure $ case runReader (evalAtomExpr tupleIn atomExpr) rstate of

761+ case runReader (evalAtomExpr tupleIn atomExpr) rstate of

762− Left _ -> False

762+ Left err -> Left err

763− Right boolAtomValue -> boolAtomValue == BoolAtom True)

763+ Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))

764

765tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation

766tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then

767− Left (error "SPAMMIT" $ AttributeNameInUseError attrName)

767+ Left (AttributeNameInUseError attrName)

768 else

769 Right rel

770

@@ -803,13 +803,15 @@ evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do

803 func <- either throwE pure (atomFunctionForName funcName functions)

804 let expectedArgCount = length (atomFuncType func) - 1

805 actualArgCount = length argTypes

806− safeInit [_] = []

807 safeInit [] = [] -- different behavior from normal init

806 safeInit [] = [] -- different behavior from normal init

808− safeInit (_:xs) = safeInit xs

807+ safeInit xs = init xs

809 if expectedArgCount /= actualArgCount then

808 if expectedArgCount /= actualArgCount then

810 throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

809 throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

811 else do

810 else do

811+ let zippedArgs = zip (safeInit (atomFuncType func)) argTypes

812+ mapM_ (\(expType, eActType) -> do

813+ actType <- either throwE pure eActType

812− mapM_ (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes))

814+ either throwE pure (atomTypeVerify expType actType)) zippedArgs

813 evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments

815 evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments

814 case evalAtomFunction func evaldArgs of

816 case evalAtomFunction func evaldArgs of

815 Left err -> throwE (AtomFunctionUserError err)

817 Left err -> throwE (AtomFunctionUserError err)

test/TutorialD/Interpreter.hs+11−2

@@ -72,7 +72,8 @@ main = do

72 testArbitraryRelation,

73 testNonEmptyListType,

74 testUnresolvedAtomTypes,

75− testWithClause

75+ testWithClause,

76+ testAtomFunctionArgumentMismatch

76 ]

77 ]

77 simpleRelTests = [("x:=true", Right relationTrue),

78 simpleRelTests = [("x:=true", Right relationTrue),

78 ("x:=false", Right relationFalse),

79 ("x:=false", Right relationFalse),

@@ -631,4 +632,12 @@ testWithClause = TestCase $ do

631

632

632 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as sp) s"

633 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as sp) s"

633

634

634−

635+testAtomFunctionArgumentMismatch :: Test

636+testAtomFunctionArgumentMismatch = TestCase $ do

637+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

638+ let err1 = "AtomTypeMismatchError"

639+ --atom function type mismatch

640+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 5}} where ^gt(@a,1.5)"

641+ --wrong argument count

642+ let err2 = "FunctionArgumentCountMismatchError"

643+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)"