43dfe2c · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP switch away from TransactionDiffs

43dfe2cAgentM7 years ago

src/lib/ProjectM36/Base.hs+11−6

compare with master

unifiedsplit

@@ -382,18 +382,17 @@ data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)

382-- | Every transaction has context-specific information attached to it.

383-- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch).

384data TransactionInfo = TransactionInfo {

385− parents :: TransactionDiffs,

385+ parents :: TransactionParents,

386 stamp :: UTCTime

387 } deriving (Show, Generic)

388+

389+type TransactionParents = NE.NonEmpty TransactionId

388{-

390{-

389data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime | -- 1 parent + n children

391data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime | -- 1 parent + n children

390 MergeTransactionInfo TransactionId TransactionId TransactionDiffs UTCTime -- 2 parents, n children

392 MergeTransactionInfo TransactionId TransactionId TransactionDiffs UTCTime -- 2 parents, n children

391 deriving (Show, Generic)

393 deriving (Show, Generic)

392-}

394-}

393

395

394−-- | Each child transaction must have a corresponding difference expression.

395−type TransactionDiffs = NE.NonEmpty (TransactionId, TransactionDiffExpr)

396−

397instance Binary TransactionInfo

396instance Binary TransactionInfo

398

397

399-- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction.

398-- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction.

@@ -489,7 +488,10 @@ data AttributeNamesBase a = AttributeNames (S.Set AttributeName) |

489 RelationalExprAttributeNames (RelationalExprBase a) -- use attribute names from the relational expression's type

488 RelationalExprAttributeNames (RelationalExprBase a) -- use attribute names from the relational expression's type

490 deriving (Eq, Show, Generic, NFData)

489 deriving (Eq, Show, Generic, NFData)

491

490

492−type AttributeNames = AttributeNamesBase ()

491+type AttributeNames = AttributeNamesBase ()

492+

493+type GraphRefAttributeNames = AttributeNamesBase TransactionId

494+

493instance Binary AttributeNames

495instance Binary AttributeNames

494

496

495-- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all.

497-- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all.

@@ -499,6 +501,7 @@ data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory

499 deriving (Show, Read)

501 deriving (Show, Read)

500

502

501type AttributeExpr = AttributeExprBase ()

503type AttributeExpr = AttributeExprBase ()

504+type GraphRefAttributeExpr = AttributeExprBase TransactionId

502

505

503-- | Create attributes dynamically.

506-- | Create attributes dynamically.

504data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

507data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

@@ -511,7 +514,9 @@ newtype TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))

511

514

512instance Binary TupleExpr

515instance Binary TupleExpr

513

516

514−type TupleExpr = TupleExprBase ()

517+type TupleExpr = TupleExprBase ()

518+

519+type GraphRefTupleExpr = TupleExprBase TransactionId

515

520

516data MergeStrategy =

521data MergeStrategy =

517 -- | After a union merge, the merge transaction is a result of union'ing relvars of the same name, introducing all uniquely-named relvars, union of constraints, union of atom functions, notifications, and types (unless the names and definitions collide, e.g. two types of the same name with different definitions)

522 -- | After a union merge, the merge transaction is a result of union'ing relvars of the same name, introducing all uniquely-named relvars, union of constraints, union of atom functions, notifications, and types (unless the names and definitions collide, e.g. two types of the same name with different definitions)

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

@@ -30,6 +30,9 @@ import Control.Monad.Trans.Reader

30import Test.QuickCheck

31import GHC

32import GHC.Paths

33+import Data.Time.Clock

34+import Data.Time.Calendar

35+import qualified Data.List.NonEmpty as NE

34data DatabaseContextExprDetails = CountUpdatedTuples

37data DatabaseContextExprDetails = CountUpdatedTuples

@@ -54,6 +57,11 @@ freshDatabaseState context = DatabaseStateElems {

54 } --future work: propagate return accumulator

57 } --future work: propagate return accumulator

56-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52

59-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52

60+data RelationalExprStateElems = RelationalExprStateTupleElems

61+ DatabaseContext

62+ TransactionGraph

63+ Maybe (Either RelationTuple Attributes)

64+

57data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr

65data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr

58 RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr

66 RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr

59 RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation

67 RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation

@@ -260,14 +268,14 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do

260 Right tupProc -> pure (Right (Extend tupProc expr))

268 Right tupProc -> pure (Right (Extend tupProc expr))

261

269

262--helper function to process relation variable creation/assignment

270--helper function to process relation variable creation/assignment

263−setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseState (Either RelationalError ())

271+setRelVar :: RelVarName -> GraphRefRelationalExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())

264−setRelVar relVarName relExpr = do

272+setRelVar relVarName relExpr transId graph = do

265 currentContext <- getStateContext

273 currentContext <- getStateContext

266 let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext

274 let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext

267 potentialContext = currentContext { relationVariables = newRelVars }

275 potentialContext = currentContext { relationVariables = newRelVars }

268 --determine when to check constraints

276 --determine when to check constraints

269

277

270− case checkConstraints potentialContext of

278+ case checkConstraints potentialContext transId graph of

271 Left err -> pure (Left err)

279 Left err -> pure (Left err)

272 Right _ -> do

280 Right _ -> do

273 putStateContext potentialContext

281 putStateContext potentialContext

@@ -289,7 +297,7 @@ deleteRelVar relVarName = do

289evalDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())

297evalDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())

290evalDatabaseContextExpr NoOperation _ _ = pure (Right ())

298evalDatabaseContextExpr NoOperation _ _ = pure (Right ())

291

299

292−evalDatabaseContextExpr (Define relVarName attrExprs) _ _ = do

300+evalDatabaseContextExpr (Define relVarName attrExprs) transId graph = do

293 relvars <- fmap relationVariables getStateContext

301 relvars <- fmap relationVariables getStateContext

294 tConss <- fmap typeConstructorMapping getStateContext

302 tConss <- fmap typeConstructorMapping getStateContext

295 let eAttrs = map (evalAttrExpr tConss) attrExprs

303 let eAttrs = map (evalAttrExpr tConss) attrExprs

@@ -304,7 +312,7 @@ evalDatabaseContextExpr (Define relVarName attrExprs) _ _ = do

304 else

312 else

305 case M.member relVarName relvars of

313 case M.member relVarName relvars of

306 True -> pure (Left (RelVarAlreadyDefinedError relVarName))

314 True -> pure (Left (RelVarAlreadyDefinedError relVarName))

307− False -> setRelVar relVarName (ExistingRelation emptyRelation) >> pure (Right ())

315+ False -> setRelVar relVarName (ExistingRelation emptyRelation) transId graph >> pure (Right ())

308 where

316 where

309 attrs = A.attributesFromList attrsList

317 attrs = A.attributesFromList attrsList

310 emptyRelation = Relation attrs emptyTupleSet

318 emptyRelation = Relation attrs emptyTupleSet

@@ -320,10 +328,10 @@ evalDatabaseContextExpr (Assign relVarName expr) transId graph = do

320 let ervExpr = runReader (evalRelationalExpr expr) relExprState

328 let ervExpr = runReader (evalRelationalExpr expr) relExprState

321 case ervExpr of

329 case ervExpr of

322 Left err -> pure (Left err)

330 Left err -> pure (Left err)

323− Right rvExpr -> setRelVar relVarName rvExpr

331+ Right rvExpr -> setRelVar relVarName rvExpr transId graph

324 Just existingRel -> do

332 Just existingRel -> do

325− let eExpectedType = typeForGraphRefRelationalExpr existingRel transId graph

333+ let eExpectedType = typeForGraphRefRelationalExpr existingRel graph

326− eNewExprType = runReader (typeForRelationalExpr expr) relExprState

334+ eNewExprType = runReader (typeForRelationalExpr expr transId graph) relExprState

327 case eExpectedType of

335 case eExpectedType of

328 Left err -> pure (Left err)

336 Left err -> pure (Left err)

329 Right expectedType ->

337 Right expectedType ->

@@ -334,7 +342,7 @@ evalDatabaseContextExpr (Assign relVarName expr) transId graph = do

334 let ervExpr = runReader (evalRelationalExpr expr) relExprState

342 let ervExpr = runReader (evalRelationalExpr expr) relExprState

335 case ervExpr of

343 case ervExpr of

336 Left err -> pure (Left err)

344 Left err -> pure (Left err)

337− Right rvExpr -> setRelVar relVarName rvExpr

345+ Right rvExpr -> setRelVar relVarName rvExpr transId graph

338 else

346 else

339 pure (Left (RelationTypeMismatchError (attributes expectedType) (attributes newExprType)))

347 pure (Left (RelationTypeMismatchError (attributes expectedType) (attributes newExprType)))

340

348

@@ -342,17 +350,17 @@ evalDatabaseContextExpr (Insert relVarName relExpr) tid graph =

342 evalDatabaseContextExpr (Assign relVarName (Union (RelationVariable relVarName ())

350 evalDatabaseContextExpr (Assign relVarName (Union (RelationVariable relVarName ())

343 relExpr)) tid graph

351 relExpr)) tid graph

344

352

345−evalDatabaseContextExpr (Delete relVarName predicate) transId _ = do

353+evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do

346 ctx <- getStateContext

354 ctx <- getStateContext

347 let rv = RelationVariable relVarName transId

355 let rv = RelationVariable relVarName transId

348 rvState = mkRelationalExprState ctx

356 rvState = mkRelationalExprState ctx

349 case runReader (processRestrictionPredicateExpr predicate) rvState of

357 case runReader (processRestrictionPredicateExpr predicate) rvState of

350 Left err -> pure (Left err)

358 Left err -> pure (Left err)

351 Right graphRefPredicate ->

359 Right graphRefPredicate ->

352− setRelVar relVarName (Restrict (NotPredicate graphRefPredicate) rv)

360+ setRelVar relVarName (Restrict (NotPredicate graphRefPredicate) rv) transId graph

353

361

354--union of restricted+updated portion and the unrestricted+unupdated portion

362--union of restricted+updated portion and the unrestricted+unupdated portion

355−evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId _ = do

363+evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId graph = do

356 context <- getStateContext

364 context <- getStateContext

357 let rvState = mkRelationalExprState context

365 let rvState = mkRelationalExprState context

358 relVarTable = relationVariables context

366 relVarTable = relationVariables context

@@ -374,9 +382,9 @@ evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr)

374 ) rv (M.toList atomExprMap)

382 ) rv (M.toList atomExprMap)

375 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds

383 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds

376 updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)

384 updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)

377− setRelVar relVarName (Union unrestrictedPortion updatedPortion)

385+ setRelVar relVarName (Union unrestrictedPortion updatedPortion) transId graph

378

386

379−evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) _ _ = do

387+evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) transId graph = do

380 currContext <- getStateContext

388 currContext <- getStateContext

381 let currDeps = inclusionDependencies currContext

389 let currDeps = inclusionDependencies currContext

382 newDeps = M.insert newDepName newDep currDeps

390 newDeps = M.insert newDepName newDep currDeps

@@ -384,7 +392,7 @@ evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) _ _ = do

384 pure (Left (InclusionDependencyNameInUseError newDepName))

392 pure (Left (InclusionDependencyNameInUseError newDepName))

385 else do

393 else do

386 let potentialContext = currContext { inclusionDependencies = newDeps }

394 let potentialContext = currContext { inclusionDependencies = newDeps }

387− case checkConstraints potentialContext of

395+ case checkConstraints potentialContext transId graph of

388 Left err -> pure (Left err)

396 Left err -> pure (Left err)

389 Right _ -> do

397 Right _ -> do

390 putStateContext potentialContext

398 putStateContext potentialContext

@@ -614,7 +622,7 @@ evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelatio

614 case existingRelVar of

622 case existingRelVar of

615 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

623 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

616 Just existingRel -> do

624 Just existingRel -> do

617− case typeForGraphRefRelationalExpr existingRel transId graph of

625+ case typeForGraphRefRelationalExpr existingRel graph of

618 Left err -> pure (Left err)

626 Left err -> pure (Left err)

619 Right relType -> do

627 Right relType -> do

620 let expectedAttributes = attributes relType

628 let expectedAttributes = attributes relType

@@ -623,7 +631,7 @@ evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelatio

623 case eitherRel of

631 case eitherRel of

624 Left err -> pure $ Left err

632 Left err -> pure $ Left err

625 Right rel ->

633 Right rel ->

626− case runState (setRelVar relVarName (ExistingRelation rel)) elems of

634+ case runState (setRelVar relVarName (ExistingRelation rel) transId graph) elems of

627 (Left err,_) -> pure (Left err)

635 (Left err,_) -> pure (Left err)

628 (Right (), elems') -> pure $ Right (context elems)

636 (Right (), elems') -> pure $ Right (context elems)

629

637

@@ -637,20 +645,28 @@ updateTupleWithAtomExprs exprMap context tupIn = do

637 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)

645 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)

638

646

639--run verification on all constraints

647--run verification on all constraints

640−checkConstraints :: DatabaseContext -> Either RelationalError ()

648+checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()

641−checkConstraints context =

649+checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

642 mapM_ (uncurry checkIncDep) (M.toList deps)

650 mapM_ (uncurry checkIncDep) (M.toList deps)

643 where

651 where

652+ potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)

653+ tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1,

654+ utctDayTime = secondsToDiffTime 0 }

655+ tempSchemas = Schemas context M.empty

656+ tempTrans = Transaction U.nil (TransactionInfo (transId NE.:| []) tempStamp) tempSchemas

657+

644 deps = inclusionDependencies context

658 deps = inclusionDependencies context

645 eval expr = evalReader (evalRelationalExpr expr)

659 eval expr = evalReader (evalRelationalExpr expr)

646 evalReader f = runReader f (RelationalExprStateElems context)

660 evalReader f = runReader f (RelationalExprStateElems context)

647 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

661 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

662+ let gfSubsetExpr = processRelationalExpr subsetExpr transId

663+ gfSupersetExpr = processRelationalExpr supersetExpr transId

648 --if both expressions are of a single-attribute (such as with a simple foreign key), the names of the attributes are irrelevant (they need not match) because the expression is unambiguous, but special-casing this to rename the attribute automatically would not be orthogonal behavior and probably cause confusion. Instead, special case the error to make it clear.

664 --if both expressions are of a single-attribute (such as with a simple foreign key), the names of the attributes are irrelevant (they need not match) because the expression is unambiguous, but special-casing this to rename the attribute automatically would not be orthogonal behavior and probably cause confusion. Instead, special case the error to make it clear.

649− typeSub <- evalReader (typeForRelationalExpr subsetExpr)

665+ typeSub <- evalReader (typeForRelationalExpr subsetExpr transId graph)

650− typeSuper <- evalReader (typeForRelationalExpr supersetExpr)

666+ typeSuper <- evalReader (typeForRelationalExpr supersetExpr transId graph)

651 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))

667 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))

652− let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)

668+ let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

653− case eval checkExpr of

669+ case evalGraphRefRelationalExpr checkExpr potentialGraph of

654 Left err -> Left err

670 Left err -> Left err

655 Right resultRel -> if resultRel == relationTrue then

671 Right resultRel -> if resultRel == relationTrue then

656 pure ()

672 pure ()

@@ -660,24 +676,23 @@ checkConstraints context =

660-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing

676-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing

661-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation

677-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation

662

678

663−typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)

679+typeForRelationalExpr :: RelationalExpr -> TransactionId -> TransactionGraph -> RelationalExprState (Either RelationalError Relation)

664−typeForRelationalExpr expr = do

680+typeForRelationalExpr expr transId graph = do

665 rstate <- ask

681 rstate <- ask

666 let context = stateElemsContext rstate

682 let context = stateElemsContext rstate

667 --replace the relationVariables context element with a cloned set of relation devoid of tuples

683 --replace the relationVariables context element with a cloned set of relation devoid of tuples

668− let context' = contextWithEmptyTupleSets context

669− rstate' = setStateElemsContext rstate context'

670 --evalRelationalExpr could still return an existing relation with tuples, so strip them

684 --evalRelationalExpr could still return an existing relation with tuples, so strip them

671− pure $ case runReader (evalRelationalExpr expr) rstate' of

685+ let gfExpr = processRelationalExpr expr transId

672− Left err -> Left err

686+ pure (typeForGraphRefRelationalExpr gfExpr graph)

673− Right typeRel -> Right (relationWithEmptyTupleSet typeRel)

674

687

675--returns a database context with all tuples removed

688--returns a database context with all tuples removed

676--this is useful for type checking and optimization

689--this is useful for type checking and optimization

690+{-

677contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext

691contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext

678contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }

692contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }

679 where

693 where

680− relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)

694+ relVars = M.map (\rel -> ExistingRelation (Relation (attributes rel) emptyTupleSet)) (relationVariables contextIn)

695+-}

681

696

682liftE :: (Monad m) => m (Either a b) -> ExceptT a m b

697liftE :: (Monad m) => m (Either a b) -> ExceptT a m b

683liftE v = do

698liftE v = do

@@ -1043,10 +1058,97 @@ processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do

1043 Left err -> pure (Left err)

1058 Left err -> pure (Left err)

1044 Right expr -> pure (Right (AttributeExtendTupleExpr nam expr))

1059 Right expr -> pure (Right (AttributeExtendTupleExpr nam expr))

1045

1060

1046−typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionId -> TransactionGraph -> Either RelationalError Relation

1061+typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation

1047−typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = mkRelation attrs emptyTupleSet

1062+typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) _ = mkRelation attrs emptyTupleSet

1048−typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))

1063+typeForGraphRefRelationalExpr (ExistingRelation rel) _ = pure (emptyRelationWithAttrs (attributes rel))

1049−typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = unimplemented

1064+typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) graph =

1065+ case mAttrExprs of

1066+ Just attrExprs -> do

1067+ attrs <- mapM (\e -> evalGraphRefAttributeExpr e graph) attrExprs

1068+ pure (emptyRelationWithAttrs attrs)

1069+typeForGraphRefRelationalExpr (RelationVariable rvName tid) graph = do

1070+ trans <- transactionForId tid graph

1071+ let relVars = relationVariables (concreteDatabaseContext trans)

1072+ case M.lookup rvName relVars of

1073+ Nothing -> Left $ RelVarNotDefinedError name

1074+ Just rvExpr -> typeForGraphRefRelationalExpr rvExpr graph

1075+typeForGraphRefRelationalExpr (Project attrNames expr) graph = do

1076+ exprType <- typeForGraphRefRelationalExpr expr graph

1077+ projectionAttrs <- evalGraphRefAttributeNames attrNames expr graph

1078+ project projectionAttrs exprType

1079+

1080+evalGraphRefAttributeNames :: AttributeNames -> GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError (S.Set AttributeName)

1081+evalGraphRefAttributeNames attrNames expr graph = do

1082+ exprTyp <- typeForGraphRefRelationalExpr expr graph

1083+ let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))

1084+ case attrNames of

1085+ AttributeNames names ->

1086+ case A.projectionAttributesForNames names (attributes exprTyp) of

1087+ Left err -> pure (Left err)

1088+ Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))

1089+

1090+ InvertedAttributeNames names -> do

1091+ let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet

1092+ if not (S.null nonExistentAttributeNames) then

1093+ pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))

1094+ else

1095+ pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))

1096+

1097+ UnionAttributeNames namesA namesB -> do

1098+ eNameSetA <- evalAttributeNames namesA expr

1099+ case eNameSetA of

1100+ Left err -> pure (Left err)

1101+ Right nameSetA -> do

1102+ eNameSetB <- evalAttributeNames namesB expr

1103+ case eNameSetB of

1104+ Left err -> pure (Left err)

1105+ Right nameSetB ->

1106+ pure (Right (S.union nameSetA nameSetB))

1107+

1108+ IntersectAttributeNames namesA namesB -> do

1109+ eNameSetA <- evalAttributeNames namesA expr

1110+ case eNameSetA of

1111+ Left err -> pure (Left err)

1112+ Right nameSetA -> do

1113+ eNameSetB <- evalAttributeNames namesB expr

1114+ case eNameSetB of

1115+ Left err -> pure (Left err)

1116+ Right nameSetB ->

1117+ pure (Right (S.intersection nameSetA nameSetB))

1118+

1119+ RelationalExprAttributeNames attrExpr -> do

1120+ eAttrExprType <- typeForRelationalExpr attrExpr

1121+ case eAttrExprType of

1122+ Left err -> pure (Left err)

1123+ Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

1124+

1125+

1126+

1050

1127

1051processAtomExpr :: AtomExpr -> TransactionId -> GraphRefAtomExpr

1128processAtomExpr :: AtomExpr -> TransactionId -> GraphRefAtomExpr

1052−processAtomExpr = unimplemented

1129+processAtomExpr (AttributeAtomExpr nam) _ = AttributeAtomExpr nam

1130+processAtomExpr (NakedAtomExpr atom) _ = NakedAtomExpr atom

1131+processAtomExpr (FunctionAtomExpr fName atomExprs ()) tid = FunctionAtomExpr fName (fmap processAtomExpr tid) tid

1132+processAtomExpr (RelationAtomExpr expr) tid = RelationAtomExpr (processRelationalExpr expr tid)

1133+processAtomExpr (ConstructedAtomExpr dConsName atomExprs) = ConstructedAtomExpr dConsName (fmap processAtomExpr tid) tid

1134+

1135+processTupleExpr :: TupleExpr -> TransactionId -> GraphRefTupleExpr

1136+processTupleExpr (TupleExpr tMap) tid = TupleExpr (M.map (processAtomExpr tid) tMap)

1137+

1138+evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> TransactionGraph -> Either RelationalError Attribute

1139+evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) graph = do

1140+ trans <- transactionForId tid graph

1141+ let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)

1142+ aType <- atomTypeForTypeConstructorValidate True tCons tConsMap M.empty

1143+ validateAtomType aType tConsMap

1144+ pure (Attribute attrName aType)

1145+

1146+--convert AttributeExpr to GraphRefAttributeExpr

1147+processAttributeExpr :: AttributeExpr -> TransactionId -> GraphRefAttributeExpr

1148+processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) tid = AttributeAndTypeNameExpr nam tCons tid

1149+processAttributeExpr (NakedAttributeExpr attr) = NakedAttributeExpr attr

1150+

1151+-- convert a RelationalExpr into a GraphRefRelationalExpr

1152+processRelationalExpr :: RelationalExpr -> TransactionId -> GraphRefRelationalExpr

1153+processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) =

1154+ MakeRelationFromExprs (fmap (fmap processAttributeExpr) mAttrs) (processTupleExprs tupleExprs)

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

@@ -4,17 +4,22 @@ import qualified Data.Set as S

4import qualified Data.UUID as U

5import Data.Time.Clock

6import qualified Data.List.NonEmpty as NE

7−import ProjectM36.TransactionDiffs

9parentIds :: Transaction -> S.Set TransactionId

8parentIds :: Transaction -> S.Set TransactionId

10−parentIds (Transaction _ tinfo _) = S.fromList (NE.toList (NE.map fst (parents tinfo)))

9+parentIds (Transaction _ tinfo _) = S.fromList (NE.toList (parents tinfo))

10+

11+rootParent :: TransactionParents

12+rootParent = singleParent U.nil

13+

14+singleParent :: TransactionId -> TransactionParents

15+singleParent tid = tid NE.:| []

12-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.

17-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.

13filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo

18filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo

14filterTransactionInfoTransactions filterIds tinfo =

19filterTransactionInfoTransactions filterIds tinfo =

15 TransactionInfo { parents = case

20 TransactionInfo { parents = case

16− NE.filter (\diff -> S.member (fst diff) filterIds) (parents tinfo) of

21+ NE.filter (\parent -> S.member parent filterIds) (parents tinfo) of

17− [] -> root

22+ [] -> rootParent

18 xs -> NE.fromList xs,

23 xs -> NE.fromList xs,

19 stamp = stamp tinfo }

24 stamp = stamp tinfo }

@@ -37,11 +42,8 @@ schemas (Transaction _ _ schemas') = schemas'

37subschemas :: Transaction -> Subschemas

42subschemas :: Transaction -> Subschemas

38subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas

43subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas

40−diffs :: Transaction -> TransactionDiffs

41−diffs (Transaction _ info _) = parents info

42−

43fresh :: TransactionId -> UTCTime -> Schemas -> Transaction

45fresh :: TransactionId -> UTCTime -> Schemas -> Transaction

44−fresh freshId stamp' newSchemas = Transaction freshId (TransactionInfo root stamp') newSchemas

46+fresh freshId stamp' newSchemas = Transaction freshId (TransactionInfo rootParent stamp') newSchemas

46timestamp :: Transaction -> UTCTime

48timestamp :: Transaction -> UTCTime

47timestamp (Transaction _ tinfo _) = stamp tinfo

49timestamp (Transaction _ tinfo _) = stamp tinfo

src/lib/ProjectM36/TransactionDiffs.hs+2

@@ -3,8 +3,10 @@ import ProjectM36.Base

3import Data.List.NonEmpty

4import Data.UUID as U

6+{-

6root :: TransactionDiffs

7root :: TransactionDiffs

7root = single U.nil NoOperation

8root = single U.nil NoOperation

9single :: TransactionId -> TransactionDiffExpr -> TransactionDiffs

10single :: TransactionId -> TransactionDiffExpr -> TransactionDiffs

10single tid expr = (tid, expr) :| []

11single tid expr = (tid, expr) :| []

12+-}