f901574 · project-m36 · git.iko.soy

git.iko.soy/project-m36

validate ConstructedAtom argument count

resolves #149

commitf901574a051375789fd0881e45db090d21ab02b7 authorAgentM <agentm@themactionfaction.com> dateTue 19 Sep 2017, 11:36 (9 years ago) parent717daca

5 files changed+35−19

compare with master

unifiedsplit

src/lib/ProjectM36/AtomType.hs+18−13 src/lib/ProjectM36/Error.hs+2−1 src/lib/ProjectM36/RelationalExpression.hs+3−3 src/lib/ProjectM36/TransactionGraph.hs+1−1 test/TutorialD/Interpreter.hs+11−1

src/lib/ProjectM36/AtomType.hs+18−13

@@ -72,18 +72,23 @@ atomTypeForDataConstructor tConss dConsName atomArgTypes =

7272

7373-- | Walks the data and type constructors to extract the type variable map.

7474resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap

75−resolveDataConstructorTypeVars dCons aTypeArgs tConss = do

76− maps <- mapM (\(dCons',aTypeArg) -> resolveDataConstructorArgTypeVars dCons' aTypeArg tConss) (zip (DCD.fields dCons) aTypeArgs)

75+resolveDataConstructorTypeVars dCons@(DataConstructorDef _ defArgs) aTypeArgs tConss = do

76+ let defCount = length defArgs

77+ argCount = length aTypeArgs

78+ if defCount /= argCount then

79+ Left (ConstructedAtomArgumentCountMismatchError defCount argCount)

80+ else do

81+ maps <- mapM (\(dCons',aTypeArg) -> resolveDataConstructorArgTypeVars dCons' aTypeArg tConss) (zip (DCD.fields dCons) aTypeArgs)

7782 --if any two maps have the same key and different values, this indicates a type arg mismatch

78− let typeVarMapFolder valMap acc = case acc of

79− Left err -> Left err

80− Right accMap -> if accMap `M.isSubmapOf` valMap then

81− Right (M.union accMap valMap)

82− else

83− Left (DataConstructorTypeVarsMismatch (DCD.name dCons) accMap valMap)

84− case foldr typeVarMapFolder (Right M.empty) maps of

85− Left err -> Left err

86− Right typeVarMaps -> pure typeVarMaps

83+ let typeVarMapFolder valMap acc = case acc of

84+ Left err -> Left err

85+ Right accMap -> if accMap `M.isSubmapOf` valMap then

86+ Right (M.union accMap valMap)

87+ else

88+ Left (DataConstructorTypeVarsMismatch (DCD.name dCons) accMap valMap)

89+ case foldr typeVarMapFolder (Right M.empty) maps of

90+ Left err -> Left err

91+ Right typeVarMaps -> pure typeVarMaps

8792 --if the data constructor cannot complete a type constructor variables (ex. "Nothing" could be Maybe Int or Maybe Text, etc.), then fill that space with TypeVar which is resolved when the relation is constructed- the relation must contain all resolved atom types.

8893

8994

@@ -111,8 +116,8 @@ resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomT

111116 Right pVarMap'

112117 else

113118 Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap'))

114−resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)

115−resolveTypeConstructorTypeVars x y _ = error $ "Unhandled type vars:" ++ show x ++ show y

119+resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)

120+resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) typ _ = Left (TypeConstructorAtomTypeMismatch tConsName typ)

116121

117122-- check that type vars on the right also appear on the left

118123-- check that the data constructor names are unique

src/lib/ProjectM36/Error.hs+2−1

@@ -63,7 +63,8 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

6363 | FunctionNameInUseError AtomFunctionName

6464 | FunctionNameNotInUseError AtomFunctionName

6565 | EmptyCommitError

66− | FunctionArgumentCountMismatch Int Int

66+ | FunctionArgumentCountMismatchError Int Int

67+ | ConstructedAtomArgumentCountMismatchError Int Int

6768 | NoSuchDataConstructorError DataConstructorName

6869 | NoSuchTypeConstructorError TypeConstructorName

6970 | InvalidAtomTypeName AtomTypeName

src/lib/ProjectM36/RelationalExpression.hs+3−3

@@ -460,7 +460,7 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) =

460460 let expectedArgCount = length (dbcFuncType func)

461461 actualArgCount = length atomArgExprs

462462 if expectedArgCount /= actualArgCount then

463− pure (Just (FunctionArgumentCountMismatch expectedArgCount actualArgCount))

463+ pure (Just (FunctionArgumentCountMismatchError expectedArgCount actualArgCount))

464464 else

465465 --check that the atom types are valid

466466 case lefts eAtomTypes of

@@ -735,7 +735,7 @@ evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do

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

736736 safeInit (_:xs) = safeInit xs

737737 if expectedArgCount /= actualArgCount then

738− throwE (FunctionArgumentCountMismatch expectedArgCount actualArgCount)

738+ throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

739739 else do

740740 _ <- mapM (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes))

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

@@ -772,7 +772,7 @@ typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

772772 RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of

773773 Left err' -> pure (error "STAMP" $ Left err')

774774 Right atom -> pure (Right (atomTypeForAtom atom))

775− Left err -> pure (error "GONK" $ Left err)

775+ Left err -> pure (Left err)

776776typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))

777777typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do

778778 context <- fmap stateElemsContext ask

src/lib/ProjectM36/TransactionGraph.hs+1−1

@@ -26,7 +26,7 @@ import Control.Arrow

2626import Data.Maybe

2727

2828{-

29−import Debug.Trace

29+--import Debug.Trace

3030import Control.Monad.Reader

3131import qualified ProjectM36.DisconnectedTransaction as D

3232-}

test/TutorialD/Interpreter.hs+11−1

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

5353 testRelationalExprStateTupleElems,

5454 testFunctionalDependencies,

5555 testEmptyCommits,

56− testIntervalAtom

56+ testIntervalAtom,

57+ testListConstructedAtom

5758 ]

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

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

@@ -469,3 +470,12 @@ testIntervalAtom = TestCase $ do

469470 executeTutorialD sessionId dbconn "y:=x:{c:=interval_overlaps(@a,@b)}"

470471 eRv <- executeRelationalExpr sessionId dbconn (Project (AttributeNames (S.fromList ["n","c"])) (RelationVariable "y" ()))

471472 assertEqual "interval overlap check" (mkRelationFromList (attributesFromList [Attribute "c" BoolAtomType,Attribute "n" IntegerAtomType]) [[BoolAtom True, IntegerAtom 1], [BoolAtom False, IntegerAtom 2]]) eRv

473+

474+testListConstructedAtom :: Test

475+testListConstructedAtom = TestCase $ do

476+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

477+ executeTutorialD sessionId dbconn "x:=relation{tuple{l Cons 4 (Cons 5 Empty)}}"

478+ let err1 = "ConstructedAtomArgumentCountMismatchError 2 1"

479+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{l Cons 4}}"

480+ let err2 = "TypeConstructorAtomTypeMismatch \"List\" IntegerAtomType"

481+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{l Cons 4 5}}"