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

git.iko.soy/project-m36

fix atom function atom type validation

resolves #64

commit0d4a061a451fa0d9b283d6518d25917f540e4a34 authorAgentM <agentm@themactionfaction.com> dateFri 7 Sep 2018, 22:42 (8 years ago) parent7177c9e

3 files changed+21−11

compare with master

unifiedsplit

src/lib/ProjectM36/IsomorphicSchema.hs−1 src/lib/ProjectM36/RelationalExpression.hs+10−8 test/TutorialD/Interpreter.hs+11−2

src/lib/ProjectM36/IsomorphicSchema.hs−1

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

1414import qualified Data.Map as M

1515import qualified Data.Set as S

1616import qualified Data.List as L

17−import qualified Data.Text as T

1817import Data.Monoid

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

2019

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

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

753753 --merge attrs into the state attributes

754754 rstate <- ask

755755 runExceptT $ do

756− aType <- liftE (typeFromAtomExpr attrs atomExpr)

756+ aType <- liftE (typeFromAtomExpr attrs atomExpr)

757757 if aType /= BoolAtomType then

758758 throwE (AtomTypeMismatchError aType BoolAtomType)

759759 else

760760 pure (\tupleIn ->

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

762− Left _ -> False

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

761+ case runReader (evalAtomExpr tupleIn atomExpr) rstate of

762+ Left err -> Left err

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

764764

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

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

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

767+ Left (AttributeNameInUseError attrName)

768768 else

769769 Right rel

770770

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

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

804804 let expectedArgCount = length (atomFuncType func) - 1

805805 actualArgCount = length argTypes

806− safeInit [_] = []

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

808− safeInit (_:xs) = safeInit xs

807+ safeInit xs = init xs

809808 if expectedArgCount /= actualArgCount then

810809 throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

811810 else do

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

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

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

813+ actType <- either throwE pure eActType

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

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

814816 case evalAtomFunction func evaldArgs of

815817 Left err -> throwE (AtomFunctionUserError err)

test/TutorialD/Interpreter.hs+11−2

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

7272 testArbitraryRelation,

7373 testNonEmptyListType,

7474 testUnresolvedAtomTypes,

75− testWithClause

75+ testWithClause,

76+ testAtomFunctionArgumentMismatch

7677 ]

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

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

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

631632

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

633634

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)"