05b5ae1 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

add outer-level attribute support to restriction relational subexpression

05b5ae1AgentM9 years ago

src/bin/TutorialD/Interpreter/RelationalExpr.hs+3−2

compare with master

unifiedsplit

@@ -148,7 +148,7 @@ restrictionPredicateP = makeExprParser predicateTerm predicateOperators

148 [InfixL (reservedOp "and" >> return AndPredicate)],

149 [InfixL (reservedOp "or" >> return OrPredicate)]

150 ]

151− predicateTerm = parens restrictionPredicateP

151+ predicateTerm = try (parens restrictionPredicateP)

152 <|> try restrictionAtomExprP

153 <|> try restrictionAttributeEqualityP

154 <|> try relationalBooleanExprP

@@ -156,7 +156,8 @@ restrictionPredicateP = makeExprParser predicateTerm predicateOperators

156

157relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

158relationalBooleanExprP = do

159− relexpr <- relExprP

159+ relexpr <- parens relExprP <|> relTerm

160+ --we can't actually detect if the type is relational boolean, so we just pass it to the next phase

160 return $ RelationalExprPredicate relexpr

161 return $ RelationalExprPredicate relexpr

161

162

162restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

163restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

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

@@ -71,7 +71,7 @@ atomTypeForAttributeName attrName attrs = do

72attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute

73attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) attrs of

74− Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName)

74+ Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

75 Just attr -> Right attr

77attributesForNames :: S.Set AttributeName -> Attributes -> Attributes

src/lib/ProjectM36/Relation.hs+9−9

@@ -12,7 +12,7 @@ import qualified ProjectM36.Attribute as A

12import qualified ProjectM36.AttributeNames as AS

13import ProjectM36.TupleSet

14import ProjectM36.Error

15−import qualified Control.Parallel.Strategies as P

15+--import qualified Control.Parallel.Strategies as P

16import qualified ProjectM36.TypeConstructorDef as TCD

17import qualified ProjectM36.DataConstructorDef as DCD

18import qualified Data.Text as T

@@ -165,8 +165,8 @@ group groupAttrNames newAttrName rel = do

165restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation

166restrictEq tuple rel = restrict rfilter rel

167 where

168− rfilter :: RelationTuple -> Bool

168+ rfilter :: RelationTuple -> Either RelationalError Bool

169− rfilter tupleIn = tupleIntersection tuple tupleIn == tuple

169+ rfilter tupleIn = pure (tupleIntersection tuple tupleIn == tuple)

170

171-- unwrap relation-valued attribute

172-- return error if relval attrs and nongroup attrs overlap

@@ -203,11 +203,11 @@ attributesForRelval relvalAttrName (Relation attrs _) = do

203 (RelationAtomType relAttrs) -> Right relAttrs

204 _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName

205

206+type RestrictionFilter = RelationTuple -> Either RelationalError Bool

206−restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation

207+restrict :: RestrictionFilter -> Relation -> Either RelationalError Relation

207−--restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset

208+restrict rfilter (Relation attrs tupset) = do

208−restrict rfilter (Relation attrs tupset) = Right $ Relation attrs processedTupSet

209+ tuples <- filterM rfilter (asList tupset)

209− where

210+ Right $ Relation attrs (RelationTupleSet tuples)

210− processedTupSet = RelationTupleSet ((filter rfilter (asList tupset)) `P.using` (P.parListChunk 1000 P.rdeepseq))

211

212--joins on columns with the same name- use rename to avoid this- base case: cartesian product

213--after changing from string atoms, there needs to be a type-checking step!

@@ -233,7 +233,7 @@ difference relA relB =

233 where

234 attrsA = attributes relA

235 attrsB = attributes relB

236− rfilter tupInA = relFold (\tupInB acc -> if acc == False then False else if tupInB == tupInA then False else True) True relB

236+ rfilter tupInA = relFold (\tupInB acc -> if acc == Right False then pure False else pure (tupInB /= tupInA)) (Right True) relB

237

238--a map should NOT change the structure of a relation, so attributes should be constant

239relMap :: (RelationTuple -> Either RelationalError RelationTuple) -> Relation -> Either RelationalError Relation

src/lib/ProjectM36/RelationalExpression.hs+57−36

@@ -195,7 +195,8 @@ evalRelationalExpr (Restrict predicateExpr relExpr) = do

195 eFilterFunc <- predicateRestrictionFilter (attributes rel) predicateExpr

196 case eFilterFunc of

197 Left err -> return $ Left err

198+ Right filterfunc -> do

198− Right filterfunc -> return $ restrict filterfunc rel

199+ pure (restrict filterfunc rel)

199

200

200evalRelationalExpr (Equals relExprA relExprB) = do

201evalRelationalExpr (Equals relExprA relExprB) = do

201 evaldA <- evalRelationalExpr relExprA

202 evaldA <- evalRelationalExpr relExprA

@@ -334,7 +335,7 @@ evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr)

334 if cardinality restrictedPortion == Finite 0 then

335 if cardinality restrictedPortion == Finite 0 then

335 pure Nothing

336 pure Nothing

336 else do

337 else do

337− unrestrictedPortion <- restrict (not . predicateFunc) rel

338+ unrestrictedPortion <- restrict (\tup -> predicateFunc tup >>= pure . not) rel

338 updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion

339 updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion

339 updatedRel <- union updatedPortion unrestrictedPortion

340 updatedRel <- union updatedPortion unrestrictedPortion

340 pure (Just updatedRel)

341 pure (Just updatedRel)

@@ -614,52 +615,73 @@ liftE v = do

614 Right val -> pure val

615 Right val -> pure val

615

616

616{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}

617{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}

617−predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError (RelationTuple -> Bool))

618+predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionFilter)

618predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do

619predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do

619 runExceptT $ do

620 runExceptT $ do

620 expr1v <- liftE (predicateRestrictionFilter attrs expr1)

621 expr1v <- liftE (predicateRestrictionFilter attrs expr1)

621 expr2v <- liftE (predicateRestrictionFilter attrs expr2)

622 expr2v <- liftE (predicateRestrictionFilter attrs expr2)

623+ pure (\x -> do

622− pure (\x -> expr1v x && expr2v x)

624+ ev1 <- expr1v x

625+ ev2 <- expr2v x

626+ pure (ev1 && ev2))

623

627

624predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do

628predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do

625 runExceptT $ do

629 runExceptT $ do

626 expr1v <- liftE (predicateRestrictionFilter attrs expr1)

630 expr1v <- liftE (predicateRestrictionFilter attrs expr1)

627 expr2v <- liftE (predicateRestrictionFilter attrs expr2)

631 expr2v <- liftE (predicateRestrictionFilter attrs expr2)

632+ pure (\x -> do

628− pure (\x -> expr1v x || expr2v x)

633+ ev1 <- expr1v x

634+ ev2 <- expr2v x

635+ pure (ev1 || ev2))

629

636

630−predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> True))

637+predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))

631

638

632predicateRestrictionFilter attrs (NotPredicate expr) = do

639predicateRestrictionFilter attrs (NotPredicate expr) = do

633 runExceptT $ do

640 runExceptT $ do

634 exprv <- liftE (predicateRestrictionFilter attrs expr)

641 exprv <- liftE (predicateRestrictionFilter attrs expr)

642+ pure (\x -> do

635− pure (\x -> not (exprv x))

643+ ev <- exprv x

636−

644+ pure (not ev))

645+

646+--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here

637−predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = runExceptT $ do

647+predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

638− --merge attrs into to state attributes

648+ rstate <- ask

639− rel <- liftE (evalRelationalExpr relExpr)

649+ pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of

640− if rel == relationTrue then

650+ Left err -> Left err

641− pure (\_ -> True)

651+ Right rel -> if arity rel /= 0 then

642− else if rel == relationFalse then

643− pure (\_ -> False)

644− else

645− throwE (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")

652+ Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")

653+ else

654+ pure (rel == relationTrue)))

646

655

647predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do

656predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do

648− --merge attrs into the state attributes

649 rstate <- ask

657 rstate <- ask

658+ let (attrs', ctxtup') = case rstate of

659+ RelationalExprStateElems _ -> (attrs, emptyTuple)

660+ RelationalExprStateAttrsElems _ _ -> (attrs, emptyTuple)

661+ RelationalExprStateTupleElems _ ctxtup -> (A.union attrs (tupleAttributes ctxtup), ctxtup)

650 runExceptT $ do

662 runExceptT $ do

651− atomExprType <- liftE (typeFromAtomExpr attrs atomExpr)

663+ atomExprType <- liftE (typeFromAtomExpr attrs' atomExpr)

652− attr <- either throwE pure (A.attributeForName attrName attrs)

664+ attr <- either throwE pure $ case A.attributeForName attrName attrs of

665+ Right attr -> Right attr

666+ Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of

667+ Right ctxattr -> Right ctxattr

668+ Left err2@(NoSuchAttributeNamesError _) -> Left err2

669+ Left err -> Left err

670+ Left err -> Left err

653 if atomExprType /= A.atomType attr then

671 if atomExprType /= A.atomType attr then

654 throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))

672 throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))

655 else

673 else

656− pure $ \tupleIn -> case atomForAttributeName attrName tupleIn of

674+ pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of

657− Left _ -> False

675+ Right atomCmp -> atomCmp == atomIn

658− Right atomIn ->

676+ Left _ -> False

659− let atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate in

677+ atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate

660− case atomEvald of

678+ in

661− Right atomCmp -> atomCmp == atomIn

679+ pure $ case atomForAttributeName attrName tupleIn of

680+ Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of

681+ Left _ -> False

682+ Right ctxatom -> evalAndCmp ctxatom

662− Left _ -> False

683+ Left _ -> False

684+ Right atomIn -> evalAndCmp atomIn

663-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance

685-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance

664predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do

686predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do

665 --merge attrs into the state attributes

687 --merge attrs into the state attributes

@@ -670,13 +692,13 @@ predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do

670 throwE (AtomTypeMismatchError aType BoolAtomType)

692 throwE (AtomTypeMismatchError aType BoolAtomType)

671 else

693 else

672 pure (\tupleIn -> do

694 pure (\tupleIn -> do

673− case runReader (evalAtomExpr tupleIn atomExpr) rstate of

695+ pure $ case runReader (evalAtomExpr tupleIn atomExpr) rstate of

674 Left _ -> False

696 Left _ -> False

675 Right boolAtomValue -> boolAtomValue == BoolAtom True)

697 Right boolAtomValue -> boolAtomValue == BoolAtom True)

676

698

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

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

678−tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then

700+tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then

679− Left $ AttributeNameInUseError attrName

701+ Left (error "SPAMMIT" $ AttributeNameInUseError attrName)

680 else

702 else

681 Right rel

703 Right rel

682

704

@@ -742,19 +764,18 @@ evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExcept

742

764

743typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)

765typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)

744typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

766typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do

745− --first, check if the attribute is in the immediate attributes

746 rstate <- ask

767 rstate <- ask

747 case A.atomTypeForAttributeName attrName attrs of

768 case A.atomTypeForAttributeName attrName attrs of

748 Right aType -> pure (Right aType)

769 Right aType -> pure (Right aType)

749 Left err@(NoSuchAttributeNamesError _) -> case rstate of

770 Left err@(NoSuchAttributeNamesError _) -> case rstate of

750 RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of

771 RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of

751− Left err' -> pure (Left err')

772+ Left err' -> pure (error "SPAMMO2" $ Left err')

752 Right attr -> pure (Right (A.atomType attr))

773 Right attr -> pure (Right (A.atomType attr))

753− RelationalExprStateElems _ -> pure (Left err)

774+ RelationalExprStateElems _ -> pure (error (show attrs) $ Left err)

754 RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of

775 RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of

755− Left err' -> pure (Left err')

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

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

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

757− Left err -> pure (Left err)

778+ Left err -> pure (error "GONK" $ Left err)

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

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

759typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do

780typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do

760 context <- liftM stateElemsContext ask

781 context <- liftM stateElemsContext ask

@@ -795,7 +816,7 @@ verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT

795 RelationalExprStateTupleElems _ _ -> throwE err

816 RelationalExprStateTupleElems _ _ -> throwE err

796 RelationalExprStateElems _ -> throwE err

817 RelationalExprStateElems _ -> throwE err

797 RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of

818 RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of

798− Left err' -> throwE err'

819+ Left err' -> throwE (error "GONK" err')

799 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))

820 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))

800 Left err -> throwE err

821 Left err -> throwE err

801verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))

822verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))

src/lib/ProjectM36/Tuple.hs+2−2

@@ -33,9 +33,9 @@ tupleAtoms (RelationTuple _ tupVec) = tupVec

34atomForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom

35atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of

36− Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName)

36+ Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

37 Just index -> case tupVec V.!? index of

38− Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName)

38+ Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))

39 Just atom -> Right atom

41{- -- resolve naming clash with Attribute and Relation later

test/TutorialD/Interpreter.hs+19−1

@@ -15,6 +15,7 @@ import ProjectM36.Base hiding (Finite)

15import ProjectM36.TransactionGraph

16import ProjectM36.Client

17import qualified ProjectM36.DisconnectedTransaction as Discon

18+import qualified ProjectM36.AttributeNames as AN

18import qualified ProjectM36.Session as Sess

19import qualified ProjectM36.Session as Sess

19import qualified ProjectM36.Attribute as A

20import qualified ProjectM36.Attribute as A

20import qualified Data.Map as M

21import qualified Data.Map as M

@@ -89,7 +90,7 @@ main = do

89 Right $ updateTupleWithAtoms (M.singleton "status" (IntAtom ((castInt statusAtom) + 10))) tuple

90 Right $ updateTupleWithAtoms (M.singleton "status" (IntAtom ((castInt statusAtom) + 10))) tuple

90 else Right tuple) suppliersRel

91 else Right tuple) suppliersRel

91 dateExampleRelTests = [("x:=s where true", Right suppliersRel),

92 dateExampleRelTests = [("x:=s where true", Right suppliersRel),

92− ("x:=s where city = \"London\"", restrict (\tuple -> atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel),

93+ ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel),

93 ("x:=s where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),

94 ("x:=s where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),

94 ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntAtom 12, TextAtom "Paris"]]),

95 ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntAtom 12, TextAtom "Paris"]]),

95 ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntAtomType]) (V.fromList [IntAtom 50])])),

96 ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntAtomType]) (V.fromList [IntAtom 50])])),

@@ -388,6 +389,23 @@ testRelationalExprStateTupleElems = TestCase $ do

388 [TextAtom "Athens", IntAtom 0]]

389 [TextAtom "Athens", IntAtom 0]]

389 assertEqual "validate parts count" expectedRel eRv

390 assertEqual "validate parts count" expectedRel eRv

390

391

392+ executeTutorialD sessionId dbconn "rv1:=relation{tuple{test 1}}"

393+ executeTutorialD sessionId dbconn "rv2:=relation{tuple{val 1},tuple{val 2}}"

394+ --check subexpression evaluation in restriction predicate

395+ -- "rv1 where ((rv2 where val=@test) {})"

396+ let correctSubexpr = Restrict (AttributeEqualityPredicate "val" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())

397+ mainExpr subexpr = (Restrict

398+ (RelationalExprPredicate

399+ (Project AN.empty subexpr)) (RelationVariable "rv1" ()))

400+ eRv2 <- executeRelationalExpr sessionId dbconn (mainExpr correctSubexpr)

401+ let expectedRel2 = mkRelationFromList (attributesFromList [Attribute "test" IntAtomType]) [[IntAtom 1]]

402+ assertEqual "validate sub-expression attribute" expectedRel2 eRv2

403+

404+ --check error in subexpression

405+ let wrongSubexpr = Restrict (AttributeEqualityPredicate "nosuchattr" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())

406+ eRv3 <- executeRelationalExpr sessionId dbconn (mainExpr wrongSubexpr)

407+ assertEqual "validate missing attribute in subexpression" (Left (NoSuchAttributeNamesError (S.singleton "nosuchattr"))) eRv3

408+

391-- | Add a functional dependency on sname -> status and insert one tuple which is valid and another tuple which is invalid.

409-- | Add a functional dependency on sname -> status and insert one tuple which is valid and another tuple which is invalid.

392testFunctionalDependencies :: Test

410testFunctionalDependencies :: Test

393testFunctionalDependencies = TestCase $ do

411testFunctionalDependencies = TestCase $ do