git.iko.soy/project-m36
on master help sign in
switch update expression to use AtomExpr instead of simplistic Atom

this was an oversight and should have been implemented when AtomExprs were introduced, but I missed it resolves #28

commita62ba7882a3f947d2c022d3a41dd3fcfaa9452d9 authorAgentM <agentm@themactionfaction.com> dateThu 11 Aug 2016, 14:23 (10 years ago) parent7c18077
7 files changed+37−19
compare with master
unifiedsplit
Database/Persist/ProjectM36.hs+4−4 ProjectM36/Base.hs+1−1 ProjectM36/Relation.hs+2−2 ProjectM36/RelationalExpression.hs+14−5 ProjectM36/Tuple.hs+3−2 TutorialD/Interpreter/DatabaseContextExpr.hs+3−3 test/TutorialD/Interpreter.hs+10−2
Database/Persist/ProjectM36.hs+4−4
@@ -197,14 +197,14 @@ deleteByKey key = do
197197updatesToUpdateMap :: (Trans.MonadIO m,
198198 PersistEntityBackend val ~ ProjectM36Backend,
199199 PersistEntity val) =>
200− [DP.Update val] -> ReaderT ProjectM36Backend m (M.Map AttributeName Atom)
200+ [DP.Update val] -> ReaderT ProjectM36Backend m (M.Map AttributeName AtomExpr)
201201updatesToUpdateMap updates = do
202202 let convertMap upd = case updateUpdate upd of
203203 DP.Assign -> let attrName = unDBName $ fieldDB $ updateFieldDef upd
204204 newAttrValue = persistValueAtom (updatePersistValue upd) in
205205 case newAttrValue of
206206 Nothing -> Trans.liftIO $ throwIO $ PersistError "atom conversion failed"
207− Just newAttrValue' -> return (attrName, newAttrValue')
207+ Just newAttrValue' -> return (attrName, NakedAtomExpr newAttrValue')
208208 _ -> Trans.liftIO $ throwIO $ PersistError "update type not supported"
209209 updateAtomList <- mapM convertMap updates
210210 return $ M.fromList updateAtomList
@@ -465,14 +465,14 @@ filterAsRestrictionPredicate filterIn = case filterIn of
465465 op -> Left $ AtomOperatorNotSupported $ T.pack (show op)
466466 Right _ -> Left $ AtomTypeNotSupported attrName
467467
468−updateToUpdateTuple :: (PersistEntity val, PersistEntityBackend val ~ ProjectM36Backend) => DPT.Update val -> Either RelationalError (AttributeName, Atom)
468+updateToUpdateTuple :: (PersistEntity val, PersistEntityBackend val ~ ProjectM36Backend) => DPT.Update val -> Either RelationalError (AttributeName, AtomExpr)
469469updateToUpdateTuple (BackendUpdate _) = error "BackendUpdate not supported"
470470updateToUpdateTuple (DPT.Update field value op) = let attrName = unDBName $ fieldDB (persistFieldDef field)
471471 atom = persistValueAtom $ toPersistValue value
472472 in case op of
473473 DPT.Assign -> case atom of
474474 Nothing -> Left $ AtomTypeNotSupported attrName
475− Just atom' -> Right $ (attrName, atom')
475+ Just atom' -> Right $ (attrName, NakedAtomExpr atom')
476476 op' -> Left $ AtomOperatorNotSupported $ T.pack (show op')
477477
478478selectionFromRestriction :: (PersistEntity val, PersistEntityBackend val ~ backend, Trans.MonadIO m, backend ~ ProjectM36Backend) => [Filter val] -> ReaderT backend m (Either RelationalError RelationalExpr)
ProjectM36/Base.hs+1−1
@@ -336,7 +336,7 @@ data DatabaseContextExpr =
336336 Assign RelVarName RelationalExpr |
337337 Insert RelVarName RelationalExpr |
338338 Delete RelVarName RestrictionPredicateExpr |
339− Update RelVarName (M.Map AttributeName Atom) RestrictionPredicateExpr |
339+ Update RelVarName (M.Map AttributeName AtomExpr) RestrictionPredicateExpr |
340340
341341 AddInclusionDependency IncDepName InclusionDependency |
342342 RemoveInclusionDependency IncDepName |
ProjectM36/Relation.hs+2−2
@@ -234,14 +234,14 @@ difference relA relB =
234234 rfilter tupInA = relFold (\tupInB acc -> if acc == False then False else if tupInB == tupInA then False else True) True relB
235235
236236--a map should NOT change the structure of a relation, so attributes should be constant
237−relMap :: (RelationTuple -> RelationTuple) -> Relation -> Either RelationalError Relation
237+relMap :: (RelationTuple -> Either RelationalError RelationTuple) -> Relation -> Either RelationalError Relation
238238relMap mapper (Relation attrs tupleSet) = do
239239 case forM (asList tupleSet) typeMapCheck of
240240 Right remappedTupleSet -> mkRelation attrs (RelationTupleSet remappedTupleSet)
241241 Left err -> Left err
242242 where
243243 typeMapCheck tupleIn = do
244− let remappedTuple = mapper tupleIn
244+ remappedTuple <- mapper tupleIn
245245 if tupleAttributes remappedTuple == tupleAttributes tupleIn
246246 then Right remappedTuple
247247 else Left $ TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs)
ProjectM36/RelationalExpression.hs+14−5
@@ -219,12 +219,12 @@ evalContextExpr (Delete relVarName predicate) = do
219219 Right rel -> setRelVar relVarName rel
220220
221221--union of restricted+updated portion and the unrestricted+unupdated portion
222−evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = do
223− currstate <- get
224− let relVarTable = relationVariables currstate
222+evalContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do
223+ context <- get
224+ let relVarTable = relationVariables context
225225 case M.lookup relVarName relVarTable of
226226 Nothing -> return $ Just (RelVarNotDefinedError relVarName)
227− Just rel -> case predicateRestrictionFilter currstate (attributes rel) restrictionPredicateExpr of
227+ Just rel -> case predicateRestrictionFilter context (attributes rel) restrictionPredicateExpr of
228228 Left err -> return $ Just err
229229 Right predicateFunc -> do
230230 case makeUpdatedRel rel of
@@ -234,7 +234,7 @@ evalContextExpr (Update relVarName attrAssignments restrictionPredicateExpr) = d
234234 makeUpdatedRel relin = do
235235 restrictedPortion <- restrict predicateFunc relin
236236 unrestrictedPortion <- restrict (not . predicateFunc) relin
237− updatedPortion <- relMap (updateTuple attrAssignments) restrictedPortion
237+ updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion
238238 union updatedPortion unrestrictedPortion
239239
240240evalContextExpr (AddInclusionDependency newDepName newDep) = do
@@ -321,6 +321,15 @@ evalContextExpr (MultipleExpr exprs) = do
321321 case catMaybes evald of
322322 [] -> return $ Nothing
323323 err:_ -> return $ Just err
324+
325+updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
326+updateTupleWithAtomExprs exprMap context tupIn = do
327+ --resolve all atom exprs
328+ let (errors, atoms) = M.mapEither (evalAtomExpr tupIn context) exprMap
329+ if length errors > 0 then
330+ Left (MultipleErrors (M.elems errors))
331+ else
332+ Right (updateTupleWithAtoms atoms tupIn)
324333
325334--run verification on all constraints
326335checkConstraints :: DatabaseContext -> Maybe RelationalError
ProjectM36/Tuple.hs+3−2
@@ -165,8 +165,9 @@ tupleIntersection tuple1 tuple2 = RelationTuple newAttrs newTupVec
165165 newAttrs = indexFilter attrs1
166166 newTupVec = indexFilter (tupleAtoms tuple1)
167167
168−updateTuple :: (M.Map AttributeName Atom) -> RelationTuple -> RelationTuple
169−updateTuple updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec
168+ -- | An optimized form of tuple update which updates vectors efficiently.
169+updateTupleWithAtoms :: (M.Map AttributeName Atom) -> RelationTuple -> RelationTuple
170+updateTupleWithAtoms updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec
170171 where
171172 updateKeysSet = M.keysSet updateMap
172173 updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs)
TutorialD/Interpreter/DatabaseContextExpr.hs+3−3
@@ -121,12 +121,12 @@ keyP = do
121121 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
122122 return $ AddInclusionDependency (T.pack keyName) newIncDep
123123
124−attributeAssignmentP :: Parser (String, Atom)
124+attributeAssignmentP :: Parser (String, AtomExpr)
125125attributeAssignmentP = do
126126 attrName <- identifier
127127 reservedOp ":="
128− atom <- stringAtomP <|> intAtomP
129− return $ (attrName, atom)
128+ atomExpr <- atomExprP
129+ return $ (attrName, atomExpr)
130130
131131addNotificationP :: Parser DatabaseContextExpr
132132addNotificationP = do
test/TutorialD/Interpreter.hs+10−2
@@ -7,6 +7,7 @@ import ProjectM36.Tuple
77import ProjectM36.TupleSet
88import ProjectM36.Error
99import ProjectM36.DatabaseContext
10+import ProjectM36.AtomFunctions.Primitive
1011import ProjectM36.DataTypes.Either
1112import ProjectM36.DataTypes.Primitive
1213import ProjectM36.DateExamples
@@ -81,6 +82,12 @@ main = do
8182 byteStringAttributes = A.attributesFromList [Attribute "y" byteStringAtomType]
8283 groupCountAttrs = A.attributesFromList [Attribute "z" intAtomType]
8384 minMaxAttrs = A.attributesFromList [Attribute "s#" textAtomType, Attribute "z" intAtomType]
85+ updateParisPlus10 = relMap (\tuple -> do
86+ statusAtom <- atomForAttributeName "status" tuple
87+ cityAtom <- atomForAttributeName "city" tuple
88+ if cityAtom == textAtom "Paris" then
89+ Right $ updateTupleWithAtoms (M.singleton "status" (intAtom ((castInt statusAtom) + 10))) tuple
90+ else Right tuple) suppliersRel
8491 dateExampleRelTests = [("x:=s where true", Right suppliersRel),
8592 ("x:=s where city = \"London\"", restrict (\tuple -> atomForAttributeName "city" tuple == (Right $ textAtom "London")) suppliersRel),
8693 ("x:=s where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),
@@ -89,8 +96,9 @@ main = do
8996 ("x:=s minus (s where status=20)", mkRelationFromList (attributes suppliersRel) [[textAtom "S2", textAtom "Jones", intAtom 10, textAtom "Paris"], [textAtom "S3", textAtom "Blake", intAtom 30, textAtom "Paris"], [textAtom "S5", textAtom "Adams", intAtom 30, textAtom "Athens"]]),
9097 --atom function tests
9198 ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),
92− ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == (Right $ textAtom "Blake") then updateTuple (M.singleton "city" (textAtom "Boston")) tuple else tuple) suppliersRel),
9399 ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [intAtom 5, Atom suppliersRel])])),
100+ ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == (Right $ textAtom "Blake") then Right $ updateTupleWithAtoms (M.singleton "city" (textAtom "Boston")) tuple else Right tuple) suppliersRel),
101+ ("x:=s; update x where city=\"Paris\" (status:=add(@status,10))", updateParisPlus10),
94102 --relatom function tests
95103 ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ intAtom 1)])),
96104 ("x:=(sp group ({s#} as y)) ungroup y", Right supplierProductsRel),
@@ -116,7 +124,7 @@ main = do
116124 ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntAtomType [intAtom 3]]]),
117125 --test Either Int Text
118126 ("x:=relation{tuple{a Left 3}}", Left (TypeConstructorTypeVarsMismatch (S.fromList ["a","b"]) (S.fromList ["a"]))), -- Left 3, alone is not enough information to imply the type
119− ("x:=relation{a Either Int Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType intAtomType textAtomType) [intAtom 3]]])
127+ ("x:=relation{a Either Int Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType intAtomType textAtomType) [intAtom 3]]])
120128 ]
121129
122130assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion