5780162 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP compilation checkpoint

5780162AgentM7 years ago

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

compare with master

unifiedsplit

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings #-}

1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveFoldable, DeriveFunctor #-}

2{-# OPTIONS_GHC -fno-warn-orphans #-}

4module ProjectM36.Base where

@@ -216,7 +216,7 @@ data RelationalExprBase a =

216 --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend

217 --Evaluate relationalExpr with scoped views

218 With [(RelVarName,RelationalExprBase a)] (RelationalExprBase a)

219− deriving (Show, Eq, Generic, NFData)

219+ deriving (Show, Eq, Generic, NFData, Foldable, Functor)

220

221instance Binary RelationalExpr

222

@@ -313,6 +313,8 @@ type DatabaseContextExpr = DatabaseContextExprBase ()

313

314type GraphRefDatabaseContextExpr = DatabaseContextExprBase TransactionId

315

316+instance Binary GraphRefDatabaseContextExpr

317+

316-- | Database context expressions modify the database context.

318-- | Database context expressions modify the database context.

317data DatabaseContextExprBase a =

319data DatabaseContextExprBase a =

318 NoOperation |

320 NoOperation |

@@ -373,7 +375,7 @@ data RestrictionPredicateExprBase a =

373 RelationalExprPredicate (RelationalExprBase a) | --type must be same as true and false relations (no attributes)

375 RelationalExprPredicate (RelationalExprBase a) | --type must be same as true and false relations (no attributes)

374 AtomExprPredicate (AtomExprBase a) | --atom must evaluate to boolean

376 AtomExprPredicate (AtomExprBase a) | --atom must evaluate to boolean

375 AttributeEqualityPredicate AttributeName (AtomExprBase a) -- relationalexpr must result in relation with single tuple

377 AttributeEqualityPredicate AttributeName (AtomExprBase a) -- relationalexpr must result in relation with single tuple

376− deriving (Show, Eq, Generic, NFData)

378+ deriving (Show, Eq, Generic, NFData, Foldable, Functor)

377

379

378instance Binary RestrictionPredicateExpr

380instance Binary RestrictionPredicateExpr

379

381

@@ -443,13 +445,13 @@ data AtomExprBase a = AttributeAtomExpr AttributeName |

443 FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |

445 FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |

444 RelationAtomExpr (RelationalExprBase a) |

446 RelationAtomExpr (RelationalExprBase a) |

445 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

447 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

446− deriving (Eq,Show,Generic, NFData)

448+ deriving (Eq,Show,Generic, NFData, Foldable, Functor)

447

449

448instance Binary AtomExpr

450instance Binary AtomExpr

449

451

450-- | Used in tuple creation when creating a relation.

452-- | Used in tuple creation when creating a relation.

451data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

453data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

452− deriving (Show, Eq, Generic, NFData)

454+ deriving (Show, Eq, Generic, NFData, Foldable, Functor)

453

455

454type ExtendTupleExpr = ExtendTupleExprBase ()

456type ExtendTupleExpr = ExtendTupleExprBase ()

455type GraphRefExtendTupleExpr = ExtendTupleExprBase TransactionId

457type GraphRefExtendTupleExpr = ExtendTupleExprBase TransactionId

@@ -500,7 +502,7 @@ data AttributeNamesBase a = AttributeNames (S.Set AttributeName) |

500 UnionAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

502 UnionAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

501 IntersectAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

503 IntersectAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

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

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

503− deriving (Eq, Show, Generic, NFData)

505+ deriving (Eq, Show, Generic, NFData, Foldable, Functor)

504

506

505type AttributeNames = AttributeNamesBase ()

507type AttributeNames = AttributeNamesBase ()

506

508

@@ -520,11 +522,11 @@ type GraphRefAttributeExpr = AttributeExprBase TransactionId

520-- | Create attributes dynamically.

522-- | Create attributes dynamically.

521data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

523data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

522 NakedAttributeExpr Attribute

524 NakedAttributeExpr Attribute

523− deriving (Eq, Show, Generic, Binary, NFData)

525+ deriving (Eq, Show, Generic, Binary, NFData, Foldable, Functor)

524

526

525-- | Dynamically create a tuple from attribute names and 'AtomExpr's.

527-- | Dynamically create a tuple from attribute names and 'AtomExpr's.

526newtype TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))

528newtype TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))

527− deriving (Eq, Show, Generic, NFData)

529+ deriving (Eq, Show, Generic, NFData, Foldable, Functor)

528

530

529instance Binary TupleExpr

531instance Binary TupleExpr

530

532

src/lib/ProjectM36/Client.hs+64−38

@@ -48,7 +48,8 @@ module ProjectM36.Client

48 RelationalExprBase(..),

49 DatabaseContextExprBase(..),

50 DatabaseContextExpr,

51− DatabaseContextIOExpr(..),

51+ DatabaseContextIOExprBase(..),

52+ DatabaseContextIOExpr,

52 Attribute(..),

53 Attribute(..),

53 MergeStrategy(..),

54 MergeStrategy(..),

54 attributesFromList,

55 attributesFromList,

@@ -121,7 +122,7 @@ import ProjectM36.TransactionGraph

121import qualified ProjectM36.Transaction as Trans

122import qualified ProjectM36.Transaction as Trans

122import ProjectM36.TransactionGraph.Persist

123import ProjectM36.TransactionGraph.Persist

123import ProjectM36.Attribute

124import ProjectM36.Attribute

124−import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr)

125+import ProjectM36.TransGraphRelationalExpression as TGRE (TransGraphRelationalExpr)

125import ProjectM36.Persist (DiskSync(..))

126import ProjectM36.Persist (DiskSync(..))

126import ProjectM36.FileLock

127import ProjectM36.FileLock

127import ProjectM36.Notifications

128import ProjectM36.Notifications

@@ -130,7 +131,6 @@ import qualified ProjectM36.DisconnectedTransaction as Discon

130import ProjectM36.Relation (typesAsRelation)

131import ProjectM36.Relation (typesAsRelation)

131import ProjectM36.ScriptSession (initScriptSession, ScriptSession)

132import ProjectM36.ScriptSession (initScriptSession, ScriptSession)

132import qualified ProjectM36.Relation as R

133import qualified ProjectM36.Relation as R

133−import qualified ProjectM36.DatabaseContext as DBC

134import Control.Exception.Base

135import GHC.Conc.Sync

136

@@ -594,19 +594,24 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither

594 Schema.processDatabaseContextExprInSchema schema expr

595 case expr' of

596 Left err -> pure (Left err)

597− Right expr'' ->

597+ Right expr'' -> do

598+ graph <- readTVar (ipTransactionGraph conf)

599+ let ctx = Sess.concreteDatabaseContext session

600+ env = RE.mkDatabaseContextEvalEnv transId graph

601+ transId = Sess.parentId session

598− case runDatabaseContextEvalMonad ctx env (optimizeAndEvalDatabaseContextExpr expr'') of

602+ case RE.runDatabaseContextEvalMonad ctx env (optimizeAndEvalDatabaseContextExpr expr'') of

599− Left err -> pure (Left err)

603+ Left err -> pure (Left err)

600− Right newState ->

604+ Right newState ->

601− if not dbc_dirty then --nothing dirtied, nothing to do

605+ if not (RE.dbc_dirty newState) then --nothing dirtied, nothing to do

602− pure (Right ())

606+ pure (Right ())

603− else do

607+ else do

604− let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas NoOperation

608+ let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas NoOperation

609+ context' = RE.dbc_context newState

605− newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr

610+ newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr

606− newSchemas = Schemas context' newSubschemas

611+ newSchemas = Schemas context' newSubschemas

607− newSession = Session newDiscon (Sess.schemaName session)

612+ newSession = Session newDiscon (Sess.schemaName session)

608− StmMap.insert newSession sessionId sessions

613+ StmMap.insert newSession sessionId sessions

609− pure (Right ())

614+ pure (Right ())

610executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

615executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

611

616

612-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead.

617-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead.

@@ -648,13 +653,18 @@ executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excEith

648 case eSession of

653 case eSession of

649 Left err -> pure (Left err)

654 Left err -> pure (Left err)

650 Right session -> do

655 Right session -> do

656+ graph <- readTVarIO (ipTransactionGraph conf)

657+ let env = RE.DatabaseContextIOEvalEnv transId graph scriptSession

658+ transId = Sess.parentId session

651− res <- RE.evalDatabaseContextIOExpr scriptSession (Sess.concreteDatabaseContext session) expr

659+ context = Sess.concreteDatabaseContext session

660+ res <- RE.runDatabaseContextIOEvalMonad env context (optimizeAndEvalDatabaseContextIOExpr expr)

652 case res of

661 case res of

653 Left err -> pure (Left err)

662 Left err -> pure (Left err)

654− Right context' -> do

663+ Right newState -> do

655 let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas NoOperation

664 let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas NoOperation

656 newSchemas = Schemas context' (Sess.subschemas session)

665 newSchemas = Schemas context' (Sess.subschemas session)

657 newSession = Session newDiscon (Sess.schemaName session)

666 newSession = Session newDiscon (Sess.schemaName session)

667+ context' = RE.dbc_context newState

658 atomically $ StmMap.insert newSession sessionId sessions

668 atomically $ StmMap.insert newSession sessionId sessions

659 pure (Right ())

669 pure (Right ())

660executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)

670executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)

@@ -674,12 +684,19 @@ executeGraphExprSTM_ freshId sessionId session sessions graphExpr graph graphTVa

674-}

684-}

675

685

676-- process notifications for commits

686-- process notifications for commits

687+executeCommitExprSTM_

688+ :: TransactionId

689+ -> TransactionGraph

690+ -> DatabaseContext

691+ -> DatabaseContext

692+ -> ClientNodes

677−executeCommitExprSTM_ :: DatabaseContext -> DatabaseContext -> ClientNodes -> STM (EvaluatedNotifications, ClientNodes)

693+ -> STM (EvaluatedNotifications, ClientNodes)

678−executeCommitExprSTM_ oldContext newContext nodes = do

694+executeCommitExprSTM_ transId graph oldContext newContext nodes = do

679 let nots = notifications oldContext

695 let nots = notifications oldContext

680− fireNots = notificationChanges nots oldContext newContext

696+ fireNots = notificationChanges nots transId graph oldContext newContext

681 evaldNots = M.map mkEvaldNot fireNots

697 evaldNots = M.map mkEvaldNot fireNots

682− evalInContext expr ctx = runReader (optimizeAndEvalRelationalExpr expr) (RE.mkRelationalExprEnv ctx)

698+ evalInContext expr ctx = optimizeAndEvalRelationalExpr (RE.mkRelationalExprEnv ctx transId graph) expr

699+

683 mkEvaldNot notif = EvaluatedNotification { notification = notif,

700 mkEvaldNot notif = EvaluatedNotification { notification = notif,

684 reportOldRelation = evalInContext (reportOldExpr notif) oldContext,

701 reportOldRelation = evalInContext (reportOldExpr notif) oldContext,

685 reportNewRelation = evalInContext (reportNewExpr notif) newContext}

702 reportNewRelation = evalInContext (reportNewExpr notif) newContext}

@@ -705,7 +722,7 @@ executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

705 Left err -> pure (Left err)

722 Left err -> pure (Left err)

706 Right (discon', graph') -> do

723 Right (discon', graph') -> do

707 --if freshId appears in the graph, then we need to pass it on

724 --if freshId appears in the graph, then we need to pass it on

708− let transIds = [freshId | isRight (transactionForId freshId graph')]

725+ let transIds = [freshId | isRight (RE.transactionForId freshId graph')]

709 pure (Right (discon', graph', transIds))

726 pure (Right (discon', graph', transIds))

710{-

727{-

711executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

728executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

@@ -785,11 +802,10 @@ executeTransGraphRelationalExpr :: SessionId -> Connection -> TransGraphRelation

785executeTransGraphRelationalExpr _ (InProcessConnection conf) tgraphExpr = excEither . atomically $ do

802executeTransGraphRelationalExpr _ (InProcessConnection conf) tgraphExpr = excEither . atomically $ do

786 let graphTvar = ipTransactionGraph conf

803 let graphTvar = ipTransactionGraph conf

787 graph <- readTVar graphTvar

804 graph <- readTVar graphTvar

788− case evalTransGraphRelationalExpr tgraphExpr graph of

805+ pure $ force $ optimizeAndEvalTransGraphRelationalExpr graph tgraphExpr

789− Left err -> pure (Left err)

790− Right relExpr -> case runReader (RE.evalRelationalExpr relExpr) (RE.mkRelationalExprState DBC.empty) of

806+{- case runReader (RE.evalRelationalExpr relExpr) (RE.mkRelationalExprState DBC.empty) of

791 Left err -> pure (Left err)

807 Left err -> pure (Left err)

792− Right rel -> pure (force (Right rel))

808+ Right rel -> pure (force (Right rel))-}

793executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr)

809executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr)

794

810

795-- | Schema expressions manipulate the isomorphic schemas for the current 'DatabaseContext'.

811-- | Schema expressions manipulate the isomorphic schemas for the current 'DatabaseContext'.

@@ -857,7 +873,10 @@ typeForRelationalExprSTM sessionId (InProcessConnection conf) relExpr = do

857 Schema.processRelationalExprInSchema schema relExpr

873 Schema.processRelationalExprInSchema schema relExpr

858 case processed of

874 case processed of

859 Left err -> pure (Left err)

875 Left err -> pure (Left err)

876+ Right relExpr' -> do

877+ let transId = Sess.parentId session

878+ graph <- readTVar (ipTransactionGraph conf)

860− Right relExpr' -> pure $ runReader (RE.typeForRelationalExpr relExpr') (RE.mkRelationalExprState (Sess.concreteDatabaseContext session))

879+ pure $ runReader (RE.typeForRelationalExpr relExpr') (RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) transId graph)

861

880

862typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection"

881typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection"

863

882

@@ -890,17 +909,22 @@ typeConstructorMapping sessionId (InProcessConnection conf) = do

890typeConstructorMapping sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTypeConstructorMapping sessionId)

909typeConstructorMapping sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTypeConstructorMapping sessionId)

891

910

892-- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated.

911-- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated.

893−planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError DatabaseContextExpr)

912+planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError GraphRefDatabaseContextExpr)

894planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do

913planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do

895 let sessions = ipSessions conf

914 let sessions = ipSessions conf

896 atomically $ do

915 atomically $ do

916+ graph <- readTVar (ipTransactionGraph conf)

897 eSession <- sessionAndSchema sessionId sessions

917 eSession <- sessionAndSchema sessionId sessions

898 case eSession of

918 case eSession of

899 Left err -> pure $ Left err

919 Left err -> pure $ Left err

920+ Right (session, _) ->

900− Right (session, _) -> if schemaName session == defaultSchemaName then

921+ if schemaName session == defaultSchemaName then do

901− pure $ evalState (applyStaticDatabaseOptimization dbExpr) (RE.freshDatabaseState (Sess.concreteDatabaseContext session))

922+ let env = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) transId graph

923+ transId = Sess.parentId session

924+ gfExpr = runReader (RE.processDatabaseContextExpr dbExpr) env

925+ pure $ runGraphRefStaticOptimizerMonad graph (optimizeGraphRefDatabaseContextExpr gfExpr)

902− else -- don't show any optimization because the current optimization infrastructure relies on access to the base context- this probably underscores the need for each schema to have its own DatabaseContext, even if it is generated on-the-fly

926+ else -- don't show any optimization because the current optimization infrastructure relies on access to the base context- this probably underscores the need for each schema to have its own DatabaseContext, even if it is generated on-the-fly-}

903− pure (Right dbExpr)

927+ pure (Left NonConcreteSchemaPlanError)

904

928

905planForDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr)

929planForDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr)

906

930

@@ -927,17 +951,18 @@ relationVariablesAsRelation :: SessionId -> Connection -> IO (Either RelationalE

927relationVariablesAsRelation sessionId (InProcessConnection conf) = do

951relationVariablesAsRelation sessionId (InProcessConnection conf) = do

928 let sessions = ipSessions conf

952 let sessions = ipSessions conf

929 atomically $ do

953 atomically $ do

954+ graph <- readTVar (ipTransactionGraph conf)

930 eSession <- sessionAndSchema sessionId sessions

955 eSession <- sessionAndSchema sessionId sessions

931 case eSession of

956 case eSession of

932 Left err -> pure (Left err)

957 Left err -> pure (Left err)

933 Right (session, schema) -> do

958 Right (session, schema) -> do

934 let context = Sess.concreteDatabaseContext session

959 let context = Sess.concreteDatabaseContext session

935 if Sess.schemaName session == defaultSchemaName then

960 if Sess.schemaName session == defaultSchemaName then

936− pure $ R.relationVariablesAsRelation (relationVariables context)

961+ pure $ RE.relationVariablesAsRelation (relationVariables context) graph

937 else

962 else

938 case Schema.relationVariablesInSchema schema context of

963 case Schema.relationVariablesInSchema schema context of

939 Left err -> pure (Left err)

964 Left err -> pure (Left err)

940− Right relvars -> pure $ R.relationVariablesAsRelation relvars

965+ Right relvars -> pure $ RE.relationVariablesAsRelation relvars graph

941

966

942relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

967relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

943

968

@@ -983,7 +1008,7 @@ headNameSTM_ sessionId sessions graphTvar = do

983 eSession <- sessionForSessionId sessionId sessions

1008 eSession <- sessionForSessionId sessionId sessions

984 case eSession of

1009 case eSession of

985 Left err -> pure (Left err)

1010 Left err -> pure (Left err)

986− Right session -> case transactionForId (Sess.parentId session) graph of

1011+ Right session -> case RE.transactionForId (Sess.parentId session) graph of

987 Left err -> pure (Left err)

1012 Left err -> pure (Left err)

988 Right parentTrans -> case headNameForTransaction parentTrans graph of

1013 Right parentTrans -> case headNameForTransaction parentTrans graph of

989 Nothing -> pure (Left UnknownHeadError)

1014 Nothing -> pure (Left UnknownHeadError)

@@ -1095,11 +1120,12 @@ commitLock_ sessionId conf stmBlock = do

1095 writeTVar graphTvar graph'

1120 writeTVar graphTvar graph'

1096 let newSession = Session discon' (Sess.schemaName session)

1121 let newSession = Session discon' (Sess.schemaName session)

1097 StmMap.insert newSession sessionId sessions

1122 StmMap.insert newSession sessionId sessions

1098− case transactionForId (Sess.parentId session) oldGraph of

1123+ case RE.transactionForId (Sess.parentId session) oldGraph of

1099 Left err -> pure $ Left err

1124 Left err -> pure $ Left err

1100 Right previousTrans ->

1125 Right previousTrans ->

1101 if not (Prelude.null transactionIdsToPersist) then do

1126 if not (Prelude.null transactionIdsToPersist) then do

1127+ let transId = Sess.parentId newSession

1102− (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes

1128+ (evaldNots, nodes) <- executeCommitExprSTM_ transId graph' (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes

1103 nodesToNotify <- stmSetToList nodes

1129 nodesToNotify <- stmSetToList nodes

1104 pure $ Right (evaldNots, nodesToNotify, graph', transactionIdsToPersist)

1130 pure $ Right (evaldNots, nodesToNotify, graph', transactionIdsToPersist)

1105 else pure (Right (M.empty, [], graph', []))

1131 else pure (Right (M.empty, [], graph', []))

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

@@ -17,7 +17,7 @@ empty = DatabaseContext { inclusionDependencies = M.empty,

18-- | convert an existing database context into its constituent expression.

19databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

20−databaseContextAsDatabaseContextExpr context = unimplemented {-MultipleExpr $ relVarsExprs ++ incDepsExprs ++ funcsExprs

20+databaseContextAsDatabaseContextExpr _ = unimplemented {-MultipleExpr $ relVarsExprs ++ incDepsExprs ++ funcsExprs

21 where

22 relVarsExprs = map (\(name, rel) -> --Assign name (ExistingRelation rel)) (M.toList (relationVariables context))

23 incDepsExprs :: [DatabaseContextExpr]

src/lib/ProjectM36/DatabaseContextFunctionUtils.hs+13−8

@@ -3,15 +3,20 @@ import ProjectM36.RelationalExpression

3import ProjectM36.Base

4import ProjectM36.DatabaseContextFunctionError

5import ProjectM36.Error

6−import Control.Monad.State

6+import ProjectM36.StaticOptimizer

7−import Control.Monad.Trans.Reader

9executeDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext

8executeDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext

10−executeDatabaseContextExpr expr tid graph context' = case runState (evalDatabaseContextExpr expr tid graph) (freshDatabaseState context') of

9+executeDatabaseContextExpr expr transId graph context' =

10+ case run of

11− (Right (), st) -> pure (context st)

11+ Right st -> pure (dbc_context st)

12− (Left err, _) -> error (show err)

12+ Left err -> error (show err)

13+ where

14+ env = mkDatabaseContextEvalEnv transId graph

15+ run = runDatabaseContextEvalMonad context' env (optimizeAndEvalDatabaseContextExpr expr)

14executeRelationalExpr :: RelationalExpr -> DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError Relation

17executeRelationalExpr :: RelationalExpr -> DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError Relation

15−executeRelationalExpr expr context tid graph = do

18+executeRelationalExpr expr context transId graph =

16− gfExpr <- runReader (evalRelationalExpr expr) (mkRelationalExprState context tid graph)

19+ run

17− evalGraphRefRelationalExpr gfExpr graph

20+ where

21+ env = mkRelationalExprEnv context transId graph

22+ run = optimizeAndEvalRelationalExpr env expr

src/lib/ProjectM36/Error.hs+2

@@ -96,6 +96,8 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

96 | SchemaCreationError SchemaError

98 | ImproperDatabaseStateError

99+

100+ | NonConcreteSchemaPlanError

101

100 | MultipleErrors [RelationalError]

102 | MultipleErrors [RelationalError]

101 deriving (Show,Eq,Generic,Binary,Typeable, NFData)

103 deriving (Show,Eq,Generic,Binary,Typeable, NFData)

src/lib/ProjectM36/GraphRefRelationalExpr.hs+26−2

@@ -2,8 +2,7 @@ module ProjectM36.GraphRefRelationalExpr where

2--evaluate relational expressions across the entire transaction graph to support cross-transaction referencing

3import ProjectM36.Base

4import ProjectM36.Error

5−import qualified ProjectM36.Attribute as A

5+import qualified Data.Set as S

6−import Control.Monad.Trans.Except

8-- core evaluation function- all other relational expr forms compile to GraphRefRelationalExpr

7-- core evaluation function- all other relational expr forms compile to GraphRefRelationalExpr

9eval :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation

8eval :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation

@@ -20,3 +19,28 @@ eval = undefined

22-}

21-}

22+

23+data SingularTransactionRef = SingularTransactionRef TransactionId |

24+ MultipleTransactionsRef |

25+ NoTransactionsRef

26+ deriving (Eq, Show)

27+

28+-- | return `Just transid` if this GraphRefRelationalExpr refers to just one transaction in the graph. This is useful for determining if certain optimizations can apply.

29+singularTransaction :: GraphRefRelationalExpr -> SingularTransactionRef

30+singularTransaction expr =

31+ if S.null transSet then

32+ NoTransactionsRef

33+ else if S.size transSet == 1 then

34+ SingularTransactionRef (head (S.toList transSet))

35+ else

36+ MultipleTransactionsRef

37+ where

38+ transSet = foldr (\transId acc -> S.insert transId acc) S.empty expr

39+

40+-- | Return True if two 'GraphRefRelationalExpr's both refer exclusively to the same transaction (or none at all).

41+inSameTransaction :: GraphRefRelationalExpr -> GraphRefRelationalExpr -> Maybe TransactionId

42+inSameTransaction exprA exprB = case (stA, stB) of

43+ (SingularTransactionRef tA, SingularTransactionRef tB) | tA == tB -> Just tA

44+ _ -> Nothing

45+ where stA = singularTransaction exprA

46+ stB = singularTransaction exprB

src/lib/ProjectM36/Notifications.hs−1

@@ -3,7 +3,6 @@ import ProjectM36.Base

3import ProjectM36.Error

4import ProjectM36.RelationalExpression

5import ProjectM36.StaticOptimizer

6−import Control.Monad.Trans.Reader

7import qualified Data.Map as M

6import qualified Data.Map as M

8import Data.Either (isRight)

7import Data.Either (isRight)

src/lib/ProjectM36/Relation.hs+1−17

@@ -4,8 +4,6 @@ import qualified Data.Set as S

4import qualified Data.HashSet as HS

5import Control.Monad

6import qualified Data.Vector as V

7−import qualified Data.Map as M

8−import ProjectM36.AtomType

9import ProjectM36.Base

7import ProjectM36.Base

10import ProjectM36.Tuple

8import ProjectM36.Tuple

11import qualified ProjectM36.Attribute as A

9import qualified ProjectM36.Attribute as A

@@ -304,20 +302,6 @@ typesAsRelation types = mkRelationFromTuples attrs tuples

304 mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " (DCD.name dCons:map (T.pack . show) (DCD.fields dCons)))) dConsList of

302 mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " (DCD.name dCons:map (T.pack . show) (DCD.fields dCons)))) dConsList of

305 Left err -> error ("mkRelationFromTuples pooped " ++ show err)

303 Left err -> error ("mkRelationFromTuples pooped " ++ show err)

306 Right rel -> RelationAtom rel

304 Right rel -> RelationAtom rel

307−

308−-- | Return a Relation describing the relation variables.

309−relationVariablesAsRelation :: M.Map RelVarName Relation -> Either RelationalError Relation

310−relationVariablesAsRelation relVarMap = mkRelationFromList attrs tups

311− where

312− subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]

313− attrs = A.attributesFromList [Attribute "name" TextAtomType,

314− Attribute "attributes" (RelationAtomType subrelAttrs)]

315− tups = map relVarToAtomList (M.toList relVarMap)

316− relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]

317− attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of

318− Left err -> error ("relationVariablesAsRelation pooped " ++ show err)

319− Right rel -> RelationAtom rel

320− attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]

321

305

322-- | Randomly resort the tuples. This is useful for emphasizing that two relations are equal even when they are printed to the console in different orders.

306-- | Randomly resort the tuples. This is useful for emphasizing that two relations are equal even when they are printed to the console in different orders.

323randomizeTupleOrder :: MonadRandom m => Relation -> m Relation

307randomizeTupleOrder :: MonadRandom m => Relation -> m Relation

@@ -330,4 +314,4 @@ oneTuple (Relation _ (RelationTupleSet [])) = Nothing

330oneTuple (Relation _ (RelationTupleSet (x:_))) = Just x

314oneTuple (Relation _ (RelationTupleSet (x:_))) = Just x

331

315

332tuplesList :: Relation -> [RelationTuple]

316tuplesList :: Relation -> [RelationTuple]

333−tuplesList (Relation _ tupleSet) = asList tupleSet

317+tuplesList (Relation _ tupleSet) = asList tupleSet

src/lib/ProjectM36/RelationalExpression.hs+50−20

@@ -18,9 +18,8 @@ import qualified ProjectM36.Attribute as A

18import qualified Data.Map as M

19import qualified Data.HashSet as HS

20import qualified Data.Set as S

21−import Control.Monad.Trans.RWS.Strict as RWS hiding (join)

21+import Control.Monad.Trans.RWS.Strict as RWS

22import Control.Monad.Trans.Class (lift)

23−import Control.Monad (forM)

24import Control.Exception

23import Control.Exception

25import Data.Maybe

24import Data.Maybe

26import Data.Either

25import Data.Either

@@ -146,9 +145,7 @@ dbcGraph :: DatabaseContextEvalMonad TransactionGraph

146dbcGraph = dce_graph <$> RWS.ask

145dbcGraph = dce_graph <$> RWS.ask

147

146

148dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv

147dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv

149−dbcRelationalExprEnv = do

148+dbcRelationalExprEnv =

150− tid <- dbcTransId

151− graph <- dbcGraph

152 mkRelationalExprEnv <$> getStateContext <*> dbcTransId <*> dbcGraph

149 mkRelationalExprEnv <$> getStateContext <*> dbcTransId <*> dbcGraph

153

150

154getStateContext :: DatabaseContextEvalMonad DatabaseContext

151getStateContext :: DatabaseContextEvalMonad DatabaseContext

@@ -161,6 +158,8 @@ putStateContext ctx' = do

161

158

162type RelationalExprState a = Reader RelationalExprEnv a

159type RelationalExprState a = Reader RelationalExprEnv a

163

160

161+type GraphRefRelationalExprR a = Reader TransactionGraph a

162+

164envContext :: RelationalExprEnv -> DatabaseContext

163envContext :: RelationalExprEnv -> DatabaseContext

165envContext = re_context

164envContext = re_context

166

165

@@ -375,15 +374,15 @@ evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do

375evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName

374evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName

376

375

377evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

376evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

378− relExprEnv <- dbcRelationalExprEnv

377+ graph <- re_graph <$> dbcRelationalExprEnv

379 context <- getStateContext

378 context <- getStateContext

380 let existingRelVar = M.lookup relVarName (relationVariables context)

379 let existingRelVar = M.lookup relVarName (relationVariables context)

381 case existingRelVar of

380 case existingRelVar of

382 Nothing -> do

381 Nothing -> do

383 setRelVar relVarName expr

382 setRelVar relVarName expr

384 Just existingRel -> do

383 Just existingRel -> do

385− let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) relExprEnv

384+ let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) graph

386− eNewExprType = runReader (typeForGraphRefRelationalExpr expr) relExprEnv

385+ eNewExprType = runReader (typeForGraphRefRelationalExpr expr) graph

387 case eExpectedType of

386 case eExpectedType of

388 Left err -> dbErr err

387 Left err -> dbErr err

389 Right expectedType ->

388 Right expectedType ->

@@ -408,20 +407,20 @@ evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

408 setRelVar relVarName (Restrict (NotPredicate predicate) rv)

407 setRelVar relVarName (Restrict (NotPredicate predicate) rv)

409

408

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

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

411−evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred) = do

410+evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

412 context <- getStateContext

411 context <- getStateContext

413 transId <- dbcTransId

412 transId <- dbcTransId

414 reEnv <- dbcRelationalExprEnv

413 reEnv <- dbcRelationalExprEnv

415 let relVarMap = relationVariables context

414 let relVarMap = relationVariables context

416 case M.lookup relVarName relVarMap of

415 case M.lookup relVarName relVarMap of

417 Nothing -> dbErr (RelVarNotDefinedError relVarName)

416 Nothing -> dbErr (RelVarNotDefinedError relVarName)

418− Just existingRvExpr -> do

417+ Just _ -> do

419− let unrestrictedPortion = Restrict (NotPredicate pred) rv

418+ let unrestrictedPortion = Restrict (NotPredicate pred') rv

420 rv = RelationVariable relVarName transId

419 rv = RelationVariable relVarName transId

421 tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict

420 tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict

422 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)

421 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)

423 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

422 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

424− restrictedPortion = Restrict pred

423+ restrictedPortion = Restrict pred'

425 updated = foldr (\(oldname, atomExpr) accum ->

424 updated = foldr (\(oldname, atomExpr) accum ->

426 let procAtomExpr = runReader (processAtomExpr atomExpr) reEnv in

425 let procAtomExpr = runReader (processAtomExpr atomExpr) reEnv in

427 updateAttr oldname procAtomExpr accum

426 updateAttr oldname procAtomExpr accum

@@ -502,7 +501,7 @@ evalGraphRefDatabaseContextExpr (RemoveTypeConstructor tConsName) = do

502 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes

501 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes

503 putStateContext $ currentContext { typeConstructorMapping = newTypes }

502 putStateContext $ currentContext { typeConstructorMapping = newTypes }

504

503

505−evalGraphRefDatabaseContextExpr (MultipleExpr exprs) = do

504+evalGraphRefDatabaseContextExpr (MultipleExpr _) = do

506 --the multiple expressions must pass the same context around- not the old unmodified context

505 --the multiple expressions must pass the same context around- not the old unmodified context

507 unimplemented

506 unimplemented

508{- evald <- forM exprs (\expr -> evalGraphRefDatabaseContextExpr expr)

507{- evald <- forM exprs (\expr -> evalGraphRefDatabaseContextExpr expr)

@@ -577,6 +576,15 @@ data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv

577

576

578type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO a

577type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO a

579

578

579+runDatabaseContextIOEvalMonad :: DatabaseContextIOEvalEnv -> DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ()) -> IO (Either RelationalError DatabaseContextEvalState)

580+runDatabaseContextIOEvalMonad env ctx m = do

581+ res <- runRWST m env freshState

582+ case res of

583+ (Left err,_,_) -> pure (Left err)

584+ (Right (),s,_) -> pure (Right s)

585+ where

586+ freshState = mkDatabaseContextEvalState ctx

587+

580requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)

588requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)

581requireScriptSession = do

589requireScriptSession = do

582 env <- RWS.ask

590 env <- RWS.ask

@@ -710,7 +718,7 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

710 case existingRelVar of

718 case existingRelVar of

711 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

719 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

712 Just existingRel -> do

720 Just existingRel -> do

713− case runReader (typeForGraphRefRelationalExpr existingRel) (mkRelationalExprEnv currentContext transId graph) of

721+ case runReader (typeForGraphRefRelationalExpr existingRel) graph of

714 Left err -> pure (Left err)

722 Left err -> pure (Left err)

715 Right relType -> do

723 Right relType -> do

716 let expectedAttributes = attributes relType

724 let expectedAttributes = attributes relType

@@ -770,7 +778,8 @@ typeForRelationalExpr expr = do

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

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

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

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

772 gfExpr <- processRelationalExpr expr

780 gfExpr <- processRelationalExpr expr

781+ graph <- re_graph <$> askEnv

773− typeForGraphRefRelationalExpr gfExpr

782+ pure $ runReader (typeForGraphRefRelationalExpr gfExpr) graph

774

783

775--returns a database context with all tuples removed

784--returns a database context with all tuples removed

776--this is useful for type checking and optimization

785--this is useful for type checking and optimization

@@ -1122,12 +1131,14 @@ evalAttributeNames attrNames expr = do

1122 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

1131 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

1123

1132

1124evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation

1133evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation

1134+--evalGraphRefRelationalExpr (MakeRelationaFromExprs

1125evalGraphRefRelationalExpr (RelationVariable name tid) graph = do

1135evalGraphRefRelationalExpr (RelationVariable name tid) graph = do

1126 ctx <- dbContextForTransId tid graph

1136 ctx <- dbContextForTransId tid graph

1127 case M.lookup name (relationVariables ctx) of

1137 case M.lookup name (relationVariables ctx) of

1128 Nothing -> Left (RelVarNotDefinedError name)

1138 Nothing -> Left (RelVarNotDefinedError name)

1129 Just rv -> evalGraphRefRelationalExpr rv graph

1139 Just rv -> evalGraphRefRelationalExpr rv graph

1130

1140

1141+

1131dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext

1142dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext

1132dbContextForTransId tid graph = do

1143dbContextForTransId tid graph = do

1133 trans <- transactionForId tid graph

1144 trans <- transactionForId tid graph

@@ -1160,7 +1171,7 @@ processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState GraphRefExtendT

1160processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =

1171processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =

1161 AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr

1172 AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr

1162

1173

1163−typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExprState (Either RelationalError Relation)

1174+typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprR (Either RelationalError Relation)

1164typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = pure $ mkRelation attrs emptyTupleSet

1175typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = pure $ mkRelation attrs emptyTupleSet

1165typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (Right (emptyRelationWithAttrs (attributes rel)))

1176typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (Right (emptyRelationWithAttrs (attributes rel)))

1166typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =

1177typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =

@@ -1171,7 +1182,8 @@ typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =

1171 [] -> pure (Right (emptyRelationWithAttrs (attributesFromList (rights eAttrs))))

1182 [] -> pure (Right (emptyRelationWithAttrs (attributesFromList (rights eAttrs))))

1172 _ -> pure (Left (someErrors (lefts eAttrs)))

1183 _ -> pure (Left (someErrors (lefts eAttrs)))

1173typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

1184typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

1174− eTrans <- currentTrans

1185+ graph <- R.ask

1186+ let eTrans = transactionForId tid graph

1175 case eTrans of

1187 case eTrans of

1176 Left err -> pure (Left err)

1188 Left err -> pure (Left err)

1177 Right trans -> do

1189 Right trans -> do

@@ -1189,7 +1201,7 @@ typeForGraphRefRelationalExpr (Project attrNames expr) = do

1189 Left err -> Left err

1201 Left err -> Left err

1190 Right projectionAttrs -> project projectionAttrs exprType

1202 Right projectionAttrs -> project projectionAttrs exprType

1191

1203

1192−evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName))

1204+evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprR (Either RelationalError (S.Set AttributeName))

1193evalGraphRefAttributeNames attrNames expr = do

1205evalGraphRefAttributeNames attrNames expr = do

1194 eExprType <- typeForGraphRefRelationalExpr expr

1206 eExprType <- typeForGraphRefRelationalExpr expr

1195 case eExprType of

1207 case eExprType of

@@ -1253,9 +1265,9 @@ processTupleExpr :: TupleExpr -> RelationalExprState GraphRefTupleExpr

1253processTupleExpr (TupleExpr tMap) =

1265processTupleExpr (TupleExpr tMap) =

1254 TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)

1266 TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)

1255

1267

1256−evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> RelationalExprState (Either RelationalError Attribute)

1268+evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprR (Either RelationalError Attribute)

1257evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

1269evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

1258− graph <- re_graph <$> askEnv

1270+ graph <- R.ask

1259 case transactionForId tid graph of

1271 case transactionForId tid graph of

1260 Left err -> pure (Left err)

1272 Left err -> pure (Left err)

1261 Right trans -> do

1273 Right trans -> do

@@ -1367,3 +1379,21 @@ processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod fun path) =

1367processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =

1379processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =

1368 CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range

1380 CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range

1369

1381

1382+-- | Return a Relation describing the relation variables.

1383+relationVariablesAsRelation :: RelationVariables -> TransactionGraph -> Either RelationalError Relation

1384+relationVariablesAsRelation relVarMap graph = do

1385+ let subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]

1386+ attrs = A.attributesFromList [Attribute "name" TextAtomType,

1387+ Attribute "attributes" (RelationAtomType subrelAttrs)]

1388+ mkRvDesc (rvName, gfExpr) = do

1389+ gfType <- runReader (typeForGraphRefRelationalExpr gfExpr) graph

1390+ pure (rvName, gfType)

1391+ relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]

1392+ attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]

1393+ attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of

1394+ Left err -> error ("relationVariablesAsRelation pooped " ++ show err)

1395+ Right rel -> RelationAtom rel

1396+ rvs <- mapM mkRvDesc (M.toList relVarMap)

1397+ let tups = map relVarToAtomList rvs

1398+ mkRelationFromList attrs tups

1399+

src/lib/ProjectM36/Server/EntryPoints.hs+1−1

@@ -83,7 +83,7 @@ handleRetrieveInclusionDependencies ti sessionId conn = do

83 ret <- timeoutOrDie ti (inclusionDependencies sessionId conn)

84 reply ret conn

86−handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError DatabaseContextExpr)

86+handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError GraphRefDatabaseContextExpr)

87handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do

88 ret <- timeoutOrDie ti (planForDatabaseContextExpr sessionId conn dbExpr)

89 reply ret conn

src/lib/ProjectM36/StaticOptimizer.hs+77−51

@@ -3,7 +3,9 @@ import ProjectM36.Base

3import ProjectM36.GraphRefRelationalExpr

4import ProjectM36.Relation

5import ProjectM36.RelationalExpression

6+import ProjectM36.TransGraphRelationalExpression as TGRE

6import ProjectM36.Error

7import ProjectM36.Error

8+import ProjectM36.Transaction

7import qualified ProjectM36.Attribute as A

9import qualified ProjectM36.Attribute as A

8import qualified ProjectM36.AttributeNames as AS

10import qualified ProjectM36.AttributeNames as AS

9import ProjectM36.TupleSet

11import ProjectM36.TupleSet

@@ -11,8 +13,6 @@ import Control.Monad.State

11import Control.Monad.Trans.Reader

13import Control.Monad.Trans.Reader

12import Control.Monad.Trans.Except

14import Control.Monad.Trans.Except

13import Data.Functor.Identity

15import Data.Functor.Identity

14−import Data.Either (rights, lefts)

15−import Control.Monad.Trans.Reader

16import qualified Data.Map as M

17import qualified Data.Set as S

@@ -21,37 +21,52 @@ type StaticOptimizerEnv = RelationalExprEnv

21type StaticOptimizerMonad a = ReaderT StaticOptimizerEnv (ExceptT RelationalError Identity) a

22-- the static optimizer performs optimizations which need not take any specific-relation statistics into account

24+type GraphRefStaticOptimizerMonad a = ReaderT TransactionGraph (ExceptT RelationalError Identity) a

25+

24-- | A temporary function to be replaced by IO-based implementation.

26-- | A temporary function to be replaced by IO-based implementation.

25optimizeAndEvalRelationalExpr :: RelationalExprEnv -> RelationalExpr -> Either RelationalError Relation

27optimizeAndEvalRelationalExpr :: RelationalExprEnv -> RelationalExpr -> Either RelationalError Relation

26optimizeAndEvalRelationalExpr env expr = do

28optimizeAndEvalRelationalExpr env expr = do

27 let gfExpr = runReader (processRelationalExpr expr) env

29 let gfExpr = runReader (processRelationalExpr expr) env

28− optExpr <- runStaticOptimizerMonad env (fullOptimizeGraphRefRelationalExpr gfExpr)

30+ optExpr <- runGraphRefStaticOptimizerMonad (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr)

29 evalGraphRefRelationalExpr optExpr (re_graph env)

31 evalGraphRefRelationalExpr optExpr (re_graph env)

31optimizeAndEvalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContextEvalMonad ()

33optimizeAndEvalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContextEvalMonad ()

32optimizeAndEvalDatabaseContextExpr expr = do

34optimizeAndEvalDatabaseContextExpr expr = do

33 env <- dbcRelationalExprEnv

35 env <- dbcRelationalExprEnv

34 let gfExpr = runReader (processDatabaseContextExpr expr) env

36 let gfExpr = runReader (processDatabaseContextExpr expr) env

35− eOptExpr = runStaticOptimizerMonad env (optimizeDatabaseContextExpr gfExpr)

37+ eOptExpr = runGraphRefStaticOptimizerMonad (re_graph env) (optimizeGraphRefDatabaseContextExpr gfExpr)

36 case eOptExpr of

38 case eOptExpr of

37 Left err -> lift (except (Left err))

39 Left err -> lift (except (Left err))

38 Right optExpr -> evalGraphRefDatabaseContextExpr optExpr

40 Right optExpr -> evalGraphRefDatabaseContextExpr optExpr

42+optimizeAndEvalTransGraphRelationalExpr :: TransactionGraph -> TransGraphRelationalExpr -> Either RelationalError Relation

43+optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do

44+ gfExpr <- TGRE.process (TransGraphEvalEnv graph) tgExpr

45+ optExpr <- runGraphRefStaticOptimizerMonad graph (fullOptimizeGraphRefRelationalExpr gfExpr)

46+ evalGraphRefRelationalExpr optExpr graph

47+

40optimizeAndEvalDatabaseContextIOExpr :: DatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

48optimizeAndEvalDatabaseContextIOExpr :: DatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

41optimizeAndEvalDatabaseContextIOExpr expr = do

49optimizeAndEvalDatabaseContextIOExpr expr = do

42 reEnv <- getDBCIORelationalExprEnv

50 reEnv <- getDBCIORelationalExprEnv

43 let gfExpr = runReader (processDatabaseContextIOExpr expr) reEnv

51 let gfExpr = runReader (processDatabaseContextIOExpr expr) reEnv

44− optExpr <- runStaticOptimizerMonad reEnv (optimizeDatbaseContextIOExpr gfExpr)

52+ eOptExpr = runStaticOptimizerMonad reEnv (optimizeDatabaseContextIOExpr gfExpr)

53+ case eOptExpr of

54+ Left err -> pure (Left err)

55+ Right optExpr ->

45− evalGraphRefDatabaseContextIOExpr optExpr

56+ evalGraphRefDatabaseContextIOExpr optExpr

48runStaticOptimizerMonad :: RelationalExprEnv -> StaticOptimizerMonad a -> Either RelationalError a

59runStaticOptimizerMonad :: RelationalExprEnv -> StaticOptimizerMonad a -> Either RelationalError a

49runStaticOptimizerMonad env m = runIdentity (runExceptT (runReaderT m env))

60runStaticOptimizerMonad env m = runIdentity (runExceptT (runReaderT m env))

51−optimizeRelationalExpr' :: RelationalExprEnv -> GraphRefRelationalExpr -> Either RelationalError GraphRefRelationalExpr

62+runGraphRefStaticOptimizerMonad :: TransactionGraph -> GraphRefStaticOptimizerMonad a -> Either RelationalError a

52−optimizeRelationalExpr' reEnv expr = runIdentity (runExceptT (runReaderT (optimizeGraphRefRelationalExpr expr) reEnv))

63+runGraphRefStaticOptimizerMonad graph m = runIdentity (runExceptT (runReaderT m graph))

65+--RelationalExprEnv should not be necessary for graph ref re optimization!

66+optimizeGraphRefRelationalExpr' :: TransactionGraph -> GraphRefRelationalExpr -> Either RelationalError GraphRefRelationalExpr

67+optimizeGraphRefRelationalExpr' graph expr = runIdentity (runExceptT (runReaderT (optimizeGraphRefRelationalExpr expr) graph))

68+

54−fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> StaticOptimizerMonad GraphRefRelationalExpr

69+fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

55fullOptimizeGraphRefRelationalExpr expr = do

70fullOptimizeGraphRefRelationalExpr expr = do

56 optExpr <- optimizeGraphRefRelationalExpr expr

71 optExpr <- optimizeGraphRefRelationalExpr expr

57 let optExpr' = applyStaticRestrictionPushdown (applyStaticRestrictionCollapse optExpr)

72 let optExpr' = applyStaticRestrictionPushdown (applyStaticRestrictionCollapse optExpr)

@@ -60,7 +75,7 @@ fullOptimizeGraphRefRelationalExpr expr = do

60-- apply optimizations which merely remove steps to become no-ops: example: projection of a relation across all of its attributes => original relation

75-- apply optimizations which merely remove steps to become no-ops: example: projection of a relation across all of its attributes => original relation

62--should optimizations offer the possibility to pure errors? If they perform the up-front type-checking, maybe so

77--should optimizations offer the possibility to pure errors? If they perform the up-front type-checking, maybe so

63−optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> StaticOptimizerMonad GraphRefRelationalExpr

78+optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

64optimizeGraphRefRelationalExpr e@(MakeStaticRelation _ _) = pure e

79optimizeGraphRefRelationalExpr e@(MakeStaticRelation _ _) = pure e

66optimizeGraphRefRelationalExpr e@(MakeRelationFromExprs _ _) = pure e

81optimizeGraphRefRelationalExpr e@(MakeRelationFromExprs _ _) = pure e

@@ -130,12 +145,12 @@ optimizeGraphRefRelationalExpr (Ungroup attrName expr) =

130

145

131--remove restriction of nothing

146--remove restriction of nothing

132optimizeGraphRefRelationalExpr (Restrict predicate expr) = do

147optimizeGraphRefRelationalExpr (Restrict predicate expr) = do

133− env <- ask

148+ graph <- ask

134 optimizedPredicate <- applyStaticPredicateOptimization predicate

149 optimizedPredicate <- applyStaticPredicateOptimization predicate

135 case optimizedPredicate of

150 case optimizedPredicate of

136 optimizedPredicate' | isTrueExpr optimizedPredicate' -> optimizeGraphRefRelationalExpr expr -- remove predicate entirely

151 optimizedPredicate' | isTrueExpr optimizedPredicate' -> optimizeGraphRefRelationalExpr expr -- remove predicate entirely

137 optimizedPredicate' | isFalseExpr optimizedPredicate' -> do -- replace where false predicate with empty relation with attributes from relexpr

152 optimizedPredicate' | isFalseExpr optimizedPredicate' -> do -- replace where false predicate with empty relation with attributes from relexpr

138− let attributesRel = runReader (typeForGraphRefRelationalExpr expr) env

153+ let attributesRel = runReader (typeForGraphRefRelationalExpr expr) graph

139 case attributesRel of

154 case attributesRel of

140 Left err -> lift (except (Left err))

155 Left err -> lift (except (Left err))

141 Right attributesRelA -> pure $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet

156 Right attributesRelA -> pure $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet

@@ -152,17 +167,17 @@ optimizeGraphRefRelationalExpr e@(Extend _ _) = pure e

152optimizeGraphRefRelationalExpr e@(With _ _) = pure e

167optimizeGraphRefRelationalExpr e@(With _ _) = pure e

153

168

154-- database context expr

169-- database context expr

155−optimizeDatabaseContextExpr :: GraphRefDatabaseContextExpr -> StaticOptimizerMonad GraphRefDatabaseContextExpr

170+optimizeGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> GraphRefStaticOptimizerMonad GraphRefDatabaseContextExpr

156−optimizeDatabaseContextExpr x@NoOperation = pure x

171+optimizeGraphRefDatabaseContextExpr x@NoOperation = pure x

157−optimizeDatabaseContextExpr x@(Define _ _) = pure x

172+optimizeGraphRefDatabaseContextExpr x@(Define _ _) = pure x

158

173

159−optimizeDatabaseContextExpr x@(Undefine _) = pure x

174+optimizeGraphRefDatabaseContextExpr x@(Undefine _) = pure x

160

175

161−optimizeDatabaseContextExpr (Assign name expr) = do

176+optimizeGraphRefDatabaseContextExpr (Assign name expr) = do

162 optExpr <- optimizeGraphRefRelationalExpr expr

177 optExpr <- optimizeGraphRefRelationalExpr expr

163 pure $ Assign name optExpr

178 pure $ Assign name optExpr

164

179

165−optimizeDatabaseContextExpr (Insert targetName expr) = do

180+optimizeGraphRefDatabaseContextExpr (Insert targetName expr) = do

166 optimizedExpr <- fullOptimizeGraphRefRelationalExpr expr

181 optimizedExpr <- fullOptimizeGraphRefRelationalExpr expr

167 if isEmptyRelationExpr optimizedExpr then -- if we are trying to insert an empty relation, do nothing

182 if isEmptyRelationExpr optimizedExpr then -- if we are trying to insert an empty relation, do nothing

168 pure NoOperation

183 pure NoOperation

@@ -173,39 +188,40 @@ optimizeDatabaseContextExpr (Insert targetName expr) = do

173 RelationVariable insName _ | insName == targetName -> pure NoOperation

188 RelationVariable insName _ | insName == targetName -> pure NoOperation

174 _ -> pure (Insert targetName optimizedExpr)

189 _ -> pure (Insert targetName optimizedExpr)

175

190

176−optimizeDatabaseContextExpr (Delete name predicate) =

191+optimizeGraphRefDatabaseContextExpr (Delete name predicate) =

177 Delete name <$> applyStaticPredicateOptimization predicate

192 Delete name <$> applyStaticPredicateOptimization predicate

178

193

179−optimizeDatabaseContextExpr (Update name upmap predicate) =

194+optimizeGraphRefDatabaseContextExpr (Update name upmap predicate) =

180 Update name upmap <$> applyStaticPredicateOptimization predicate

195 Update name upmap <$> applyStaticPredicateOptimization predicate

181

196

182−optimizeDatabaseContextExpr dep@(AddInclusionDependency _ _) = pure dep

197+optimizeGraphRefDatabaseContextExpr dep@(AddInclusionDependency _ _) = pure dep

183

198

184−optimizeDatabaseContextExpr (RemoveInclusionDependency name) = pure (RemoveInclusionDependency name)

199+optimizeGraphRefDatabaseContextExpr (RemoveInclusionDependency name) = pure (RemoveInclusionDependency name)

185

200

186−optimizeDatabaseContextExpr (AddNotification name triggerExpr resultOldExpr resultNewExpr) =

201+optimizeGraphRefDatabaseContextExpr (AddNotification name triggerExpr resultOldExpr resultNewExpr) =

187 --we can't optimize these expressions until they run

202 --we can't optimize these expressions until they run

188 pure (AddNotification name triggerExpr resultOldExpr resultNewExpr)

203 pure (AddNotification name triggerExpr resultOldExpr resultNewExpr)

189

204

190−optimizeDatabaseContextExpr notif@(RemoveNotification _) = pure notif

205+optimizeGraphRefDatabaseContextExpr notif@(RemoveNotification _) = pure notif

191

206

192−optimizeDatabaseContextExpr c@(AddTypeConstructor _ _) = pure c

207+optimizeGraphRefDatabaseContextExpr c@(AddTypeConstructor _ _) = pure c

193−optimizeDatabaseContextExpr c@(RemoveTypeConstructor _) = pure c

208+optimizeGraphRefDatabaseContextExpr c@(RemoveTypeConstructor _) = pure c

194−optimizeDatabaseContextExpr c@(RemoveAtomFunction _) = pure c

209+optimizeGraphRefDatabaseContextExpr c@(RemoveAtomFunction _) = pure c

195−optimizeDatabaseContextExpr c@(RemoveDatabaseContextFunction _) = pure c

210+optimizeGraphRefDatabaseContextExpr c@(RemoveDatabaseContextFunction _) = pure c

196−optimizeDatabaseContextExpr c@(ExecuteDatabaseContextFunction _ _) = pure c

211+optimizeGraphRefDatabaseContextExpr c@(ExecuteDatabaseContextFunction _ _) = pure c

197

212

198--optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned

213--optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned

199

214

200--applyStaticDatabaseOptimization (MultipleExpr exprs) = pure $ Right $ MultipleExpr exprs

215--applyStaticDatabaseOptimization (MultipleExpr exprs) = pure $ Right $ MultipleExpr exprs

201--for multiple expressions, we must evaluate

216--for multiple expressions, we must evaluate

202−applyStaticDatabaseOptimization (MultipleExpr exprs) = do

217+optimizeGraphRefDatabaseContextExpr (MultipleExpr _) = do

203 --a previous expression in the exprs list could create a relvar; we don't want to miss it, so we clear the tuples and execute the expression to get an empty relation in the relvar

218 --a previous expression in the exprs list could create a relvar; we don't want to miss it, so we clear the tuples and execute the expression to get an empty relation in the relvar

219+ unimplemented

204− let processEmptyRelVars env = env { relationVariables = mkEmptyRelVars (relationVariables env) }

220+{- let processEmptyRelVars env = env { relationVariables = mkEmptyRelVars (relationVariables env) }

205− MultipleExpr <$> local processEmptyRelVars (mapM applyStaticDatabaseOptimization exprs)

221+ MultipleExpr <$> local processEmptyRelVars (mapM applyStaticDatabaseOptimization exprs)-}

206

222

207

223

208−applyStaticPredicateOptimization :: GraphRefRestrictionPredicateExpr -> StaticOptimizerMonad GraphRefRestrictionPredicateExpr

224+applyStaticPredicateOptimization :: GraphRefRestrictionPredicateExpr -> GraphRefStaticOptimizerMonad GraphRefRestrictionPredicateExpr

209applyStaticPredicateOptimization predi = do

225applyStaticPredicateOptimization predi = do

210 optPred <- case predi of

226 optPred <- case predi of

211-- where x and x => where x

227-- where x and x => where x

@@ -298,18 +314,22 @@ isStaticAtomExpr FunctionAtomExpr{} = False

298isStaticAtomExpr RelationAtomExpr{} = False

314isStaticAtomExpr RelationAtomExpr{} = False

299

315

300--if the projection of a join only uses the attributes from one of the expressions and there is a foreign key relationship between the expressions, we know that the join is inconsequential and can be removed

316--if the projection of a join only uses the attributes from one of the expressions and there is a foreign key relationship between the expressions, we know that the join is inconsequential and can be removed

301−applyStaticJoinElimination :: GraphRefRelationalExpr -> StaticOptimizerMonad GraphRefRelationalExpr

317+applyStaticJoinElimination :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

302applyStaticJoinElimination expr@(Project attrNameSet (Join exprA exprB)) = do

318applyStaticJoinElimination expr@(Project attrNameSet (Join exprA exprB)) = do

303− env <- ask

319+ graph <- ask

320+ case inSameTransaction exprA exprB of

321+ -- the sub exprs are in different transactions or none at all, so we cannot extract inclusion dependencies across transaction boundaries

322+ Nothing -> pure expr

323+ Just commonTransId -> do

304− let typeForExpr e = runReader (typeForGraphRefRelationalExpr e) env

324+ let typeForExpr e = runReader (typeForGraphRefRelationalExpr e) graph

305− eProjType = typeForExpr expr

325+ eProjType = typeForExpr expr

306− eTypeA = typeForExpr exprA

326+ eTypeA = typeForExpr exprA

307− eTypeB = typeForExpr exprB

327+ eTypeB = typeForExpr exprB

308− liftErr = lift . except . Left

328+ liftErr = lift . except . Left

309− case eProjType of

329+ case eProjType of

310− Left err -> liftErr err

330+ Left err -> liftErr err

311− Right projType ->

331+ Right projType ->

312− case eTypeA of

332+ case eTypeA of

313 Left err -> liftErr err

333 Left err -> liftErr err

314 Right typeA ->

334 Right typeA ->

315 case eTypeB of

335 case eTypeB of

@@ -327,16 +347,20 @@ applyStaticJoinElimination expr@(Project attrNameSet (Join exprA exprB)) = do

327 Nothing -> -- this optimization does not apply

347 Nothing -> -- this optimization does not apply

328 pure expr

348 pure expr

329 Just ((joinedExpr, joinedType), (unjoinedExpr, _)) -> do

349 Just ((joinedExpr, joinedType), (unjoinedExpr, _)) -> do

350+ --lookup transaction

351+ trans <- lift $ except (transactionForId commonTransId graph)

330 --scan inclusion dependencies for a foreign key relationship

352 --scan inclusion dependencies for a foreign key relationship

331− incDeps <- inclusionDependencies . re_context <$> ask

353+ let incDeps = inclusionDependencies commonContext

354+ commonContext = concreteDatabaseContext trans

355+ reEnv = mkRelationalExprEnv commonContext commonTransId graph

332− let fkConstraint = foldM isFkConstraint False incDeps

356+ fkConstraint = foldM isFkConstraint False incDeps

333 --search for matching fk constraint

357 --search for matching fk constraint

334 isFkConstraint acc (InclusionDependency (Project subAttrNames subrv) (Project _ superrv)) = do

358 isFkConstraint acc (InclusionDependency (Project subAttrNames subrv) (Project _ superrv)) = do

335− let gfSubAttrNames = runReader (processAttributeNames subAttrNames) env

359+ let gfSubAttrNames = runReader (processAttributeNames subAttrNames) reEnv

336− gfSubRv = runReader (processRelationalExpr subrv) env

360+ gfSubRv = runReader (processRelationalExpr subrv) reEnv

337− gfSuperRv = runReader (processRelationalExpr superrv) env

361+ gfSuperRv = runReader (processRelationalExpr superrv) reEnv

338

362

339− case runReader (evalGraphRefAttributeNames gfSubAttrNames expr) env of

363+ case runReader (evalGraphRefAttributeNames gfSubAttrNames expr) graph of

340 Left _ -> pure acc

364 Left _ -> pure acc

341 Right subAttrNameSet ->

365 Right subAttrNameSet ->

342 pure (acc || (joinedExpr == gfSubRv &&

366 pure (acc || (joinedExpr == gfSubRv &&

@@ -438,4 +462,6 @@ applyStaticRestrictionPushdown expr = case expr of

438 Extend n sub ->

462 Extend n sub ->

439 Extend n (applyStaticRestrictionPushdown sub)

463 Extend n (applyStaticRestrictionPushdown sub)

440

464

441−

465+-- no optimizations available

466+optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> StaticOptimizerMonad GraphRefDatabaseContextIOExpr

467+optimizeDatabaseContextIOExpr x = pure x

src/lib/ProjectM36/TransGraphRelationalExpression.hs+75−85

@@ -4,12 +4,7 @@

4module ProjectM36.TransGraphRelationalExpression where

5import ProjectM36.Base

6import ProjectM36.TransactionGraph

7−import ProjectM36.Transaction

8−import ProjectM36.GraphRefRelationalExpr

9−import ProjectM36.RelationalExpression hiding (liftE)

10import ProjectM36.Error

7import ProjectM36.Error

11−import ProjectM36.Tuple

12−import ProjectM36.AtomType

13import qualified Data.Map as M

8import qualified Data.Map as M

14import Control.Monad.Trans.Reader

9import Control.Monad.Trans.Reader

15import Control.Monad.Trans.Class

10import Control.Monad.Trans.Class

@@ -44,24 +39,20 @@ instance Binary TransGraphAtomExpr

45type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

40type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

47−data TransGraphEvalEnv = TransGraphEvalEnv { transId :: TransactionId,

42+data TransGraphEvalEnv = TransGraphEvalEnv {

48− graph :: TransactionGraph

43+ tge_graph :: TransactionGraph

49− }

44+ }

51type TransGraphEvalMonad a = ReaderT TransGraphEvalEnv (ExceptT RelationalError Identity) a

46type TransGraphEvalMonad a = ReaderT TransGraphEvalEnv (ExceptT RelationalError Identity) a

53−run :: TransGraphEvalEnv -> TransGraphRelationalExpr -> Either RelationalError GraphRefRelationalExpr

48+process :: TransGraphEvalEnv -> TransGraphRelationalExpr -> Either RelationalError GraphRefRelationalExpr

54−run env texpr = runIdentity (runExceptT (runReaderT (evalTransGraphRelationalExpr texpr) env))

49+process env texpr = runIdentity (runExceptT (runReaderT (processTransGraphRelationalExpr texpr) env))

56liftE :: Either RelationalError a -> TransGraphEvalMonad a

51liftE :: Either RelationalError a -> TransGraphEvalMonad a

57liftE = lift . except

52liftE = lift . except

59−

60−askTid :: TransGraphEvalMonad TransactionId

61−askTid = transId <$> ask

62−

63askGraph :: TransGraphEvalMonad TransactionGraph

54askGraph :: TransGraphEvalMonad TransactionGraph

64−askGraph = graph <$> ask

55+askGraph = tge_graph <$> ask

66findTransId :: TransactionIdLookup -> TransGraphEvalMonad TransactionId

57findTransId :: TransactionIdLookup -> TransGraphEvalMonad TransactionId

67findTransId tlook = transactionId <$> findTrans tlook

58findTransId tlook = transactionId <$> findTrans tlook

@@ -72,76 +63,75 @@ findTrans tlook = do

72 liftE $ lookupTransaction graph tlook

63 liftE $ lookupTransaction graph tlook

74-- OUTDATED a previous attempt at this function attempted to convert TransGraphRelationalExpr to RelationalExpr by resolving the transaction lookups. However, there is no way to resolve a FunctionAtomExpr to an Atom without fully evaluating the higher levels (TupleExpr, etc.). An anonymous function expression cannot be serialized, so that workaround is out. Still, I suspect we can reuse the existing static optimizer logic to work on both structures. The current conversion reduces the chance of whole-query optimization due to full-evaluation on top of full-evaluation, so this function would benefit from some re-design.

65-- OUTDATED a previous attempt at this function attempted to convert TransGraphRelationalExpr to RelationalExpr by resolving the transaction lookups. However, there is no way to resolve a FunctionAtomExpr to an Atom without fully evaluating the higher levels (TupleExpr, etc.). An anonymous function expression cannot be serialized, so that workaround is out. Still, I suspect we can reuse the existing static optimizer logic to work on both structures. The current conversion reduces the chance of whole-query optimization due to full-evaluation on top of full-evaluation, so this function would benefit from some re-design.

75−evalTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransGraphEvalMonad GraphRefRelationalExpr

66+processTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransGraphEvalMonad GraphRefRelationalExpr

76−evalTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

67+processTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

77− tupleExprs' <- mapM evalTransGraphTupleExpr tupleExprs

68+ tupleExprs' <- mapM processTransGraphTupleExpr tupleExprs

78 case mAttrExprs of

69 case mAttrExprs of

79 Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')

70 Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')

80 Just attrExprs -> do

71 Just attrExprs -> do

81− attrExprs' <- mapM evalTransGraphAttributeExpr attrExprs

72+ attrExprs' <- mapM processTransGraphAttributeExpr attrExprs

82 pure (MakeRelationFromExprs (Just attrExprs') tupleExprs')

73 pure (MakeRelationFromExprs (Just attrExprs') tupleExprs')

83−evalTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)

74+processTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)

84−evalTransGraphRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)

75+processTransGraphRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)

85−evalTransGraphRelationalExpr (RelationVariable rvname transLookup) =

76+processTransGraphRelationalExpr (RelationVariable rvname transLookup) =

86 RelationVariable rvname <$> findTransId transLookup

77 RelationVariable rvname <$> findTransId transLookup

87−evalTransGraphRelationalExpr (Project transAttrNames expr) =

78+processTransGraphRelationalExpr (Project transAttrNames expr) =

88− Project <$> evalTransAttributeNames transAttrNames <*> evalTransGraphRelationalExpr expr

79+ Project <$> processTransGraphAttributeNames transAttrNames <*> processTransGraphRelationalExpr expr

89−evalTransGraphRelationalExpr (Union exprA exprB) =

80+processTransGraphRelationalExpr (Union exprA exprB) =

90− Union <$> evalTransGraphRelationalExpr exprA <*> evalTransGraphRelationalExpr exprB

81+ Union <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB

91−evalTransGraphRelationalExpr (Join exprA exprB) =

82+processTransGraphRelationalExpr (Join exprA exprB) =

92− Join <$> evalTransGraphRelationalExpr exprA <*> evalTransGraphRelationalExpr exprB

83+ Join <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB

93−evalTransGraphRelationalExpr (Rename attrName1 attrName2 expr) =

84+processTransGraphRelationalExpr (Rename attrName1 attrName2 expr) =

94− Rename attrName1 attrName2 <$> evalTransGraphRelationalExpr expr

85+ Rename attrName1 attrName2 <$> processTransGraphRelationalExpr expr

95−evalTransGraphRelationalExpr (Difference exprA exprB) =

86+processTransGraphRelationalExpr (Difference exprA exprB) =

96− Difference <$> evalTransGraphRelationalExpr exprA <*> evalTransGraphRelationalExpr exprB

87+ Difference <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB

97−evalTransGraphRelationalExpr (Group transAttrNames attrName expr) =

88+processTransGraphRelationalExpr (Group transAttrNames attrName expr) =

98 Group <$>

89 Group <$>

99− evalTransAttributeNames transAttrNames <*>

90+ processTransGraphAttributeNames transAttrNames <*>

100 pure attrName <*>

91 pure attrName <*>

101− evalTransGraphRelationalExpr expr

92+ processTransGraphRelationalExpr expr

102−evalTransGraphRelationalExpr (Ungroup attrName expr) =

93+processTransGraphRelationalExpr (Ungroup attrName expr) =

103− Ungroup attrName <$> evalTransGraphRelationalExpr expr

94+ Ungroup attrName <$> processTransGraphRelationalExpr expr

104−evalTransGraphRelationalExpr (Restrict predicateExpr expr) =

95+processTransGraphRelationalExpr (Restrict predicateExpr expr) =

105 Restrict <$> evalTransGraphRestrictionPredicateExpr predicateExpr <*>

96 Restrict <$> evalTransGraphRestrictionPredicateExpr predicateExpr <*>

106− evalTransGraphRelationalExpr expr

97+ processTransGraphRelationalExpr expr

107−evalTransGraphRelationalExpr (Equals exprA exprB) = do

98+processTransGraphRelationalExpr (Equals exprA exprB) = do

108− exprA' <- evalTransGraphRelationalExpr exprA

99+ exprA' <- processTransGraphRelationalExpr exprA

109− exprB' <- evalTransGraphRelationalExpr exprB

100+ exprB' <- processTransGraphRelationalExpr exprB

110 pure (Equals exprA' exprB')

101 pure (Equals exprA' exprB')

111−evalTransGraphRelationalExpr (NotEquals exprA exprB) = do

102+processTransGraphRelationalExpr (NotEquals exprA exprB) = do

112− exprA' <- evalTransGraphRelationalExpr exprA

103+ exprA' <- processTransGraphRelationalExpr exprA

113− exprB' <- evalTransGraphRelationalExpr exprB

104+ exprB' <- processTransGraphRelationalExpr exprB

114 pure (NotEquals exprA' exprB')

105 pure (NotEquals exprA' exprB')

115−evalTransGraphRelationalExpr (Extend extendExpr expr) = do

106+processTransGraphRelationalExpr (Extend extendExpr expr) = do

116− extendExpr' <- evalTransGraphExtendTupleExpr extendExpr

107+ extendExpr' <- processTransGraphExtendTupleExpr extendExpr

117− expr' <- evalTransGraphRelationalExpr expr

108+ expr' <- processTransGraphRelationalExpr expr

118 pure (Extend extendExpr' expr')

109 pure (Extend extendExpr' expr')

119−evalTransGraphRelationalExpr (With views expr) = do

110+processTransGraphRelationalExpr (With views expr) = do

120 evaldViews <- mapM (\(vname, vexpr) -> do

111 evaldViews <- mapM (\(vname, vexpr) -> do

121− vexpr' <- evalTransGraphRelationalExpr vexpr

112+ vexpr' <- processTransGraphRelationalExpr vexpr

122 pure (vname, vexpr')

113 pure (vname, vexpr')

123 ) views

114 ) views

124− expr' <- evalTransGraphRelationalExpr expr

115+ expr' <- processTransGraphRelationalExpr expr

125 pure (With evaldViews expr')

116 pure (With evaldViews expr')

126

117

127−evalTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr

118+processTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr

128−evalTransGraphTupleExpr (TupleExpr attrMap) = do

119+processTransGraphTupleExpr (TupleExpr attrMap) = do

129− graph <- askGraph

130 let attrAssoc = mapM (\(attrName, atomExpr) -> do

120 let attrAssoc = mapM (\(attrName, atomExpr) -> do

131− aExpr <- evalTransGraphAtomExpr atomExpr

121+ aExpr <- processTransGraphAtomExpr atomExpr

132 pure (attrName, aExpr)

122 pure (attrName, aExpr)

133 ) (M.toList attrMap)

123 ) (M.toList attrMap)

134 TupleExpr . M.fromList <$> attrAssoc

124 TupleExpr . M.fromList <$> attrAssoc

135

125

136−evalTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr

126+processTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr

137−evalTransGraphAtomExpr (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname

127+processTransGraphAtomExpr (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname

138−evalTransGraphAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom

128+processTransGraphAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom

139−evalTransGraphAtomExpr (FunctionAtomExpr funcName args tLookup) =

129+processTransGraphAtomExpr (FunctionAtomExpr funcName args tLookup) =

140− FunctionAtomExpr funcName <$> mapM evalTransGraphAtomExpr args <*> findTransId tLookup

130+ FunctionAtomExpr funcName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup

141−evalTransGraphAtomExpr (RelationAtomExpr expr) =

131+processTransGraphAtomExpr (RelationAtomExpr expr) =

142− RelationAtomExpr <$> evalTransGraphRelationalExpr expr

132+ RelationAtomExpr <$> processTransGraphRelationalExpr expr

143−evalTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =

133+processTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =

144− ConstructedAtomExpr dConsName <$> mapM evalTransGraphAtomExpr args <*> findTransId tLookup

134+ ConstructedAtomExpr dConsName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup

145evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr

135evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr

146evalTransGraphRestrictionPredicateExpr TruePredicate = pure TruePredicate

136evalTransGraphRestrictionPredicateExpr TruePredicate = pure TruePredicate

147evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) = do

137evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) = do

@@ -156,35 +146,35 @@ evalTransGraphRestrictionPredicateExpr (NotPredicate expr) = do

156 let expr' = evalTransGraphRestrictionPredicateExpr expr

146 let expr' = evalTransGraphRestrictionPredicateExpr expr

157 NotPredicate <$> expr'

147 NotPredicate <$> expr'

158evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) = do

148evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) = do

159− let expr' = evalTransGraphRelationalExpr expr

149+ let expr' = processTransGraphRelationalExpr expr

160 RelationalExprPredicate <$> expr'

150 RelationalExprPredicate <$> expr'

161evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) = do

151evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) = do

162− let expr' = evalTransGraphAtomExpr expr

152+ let expr' = processTransGraphAtomExpr expr

163 AtomExprPredicate <$> expr'

153 AtomExprPredicate <$> expr'

164evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) = do

154evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) = do

165− let expr' = evalTransGraphAtomExpr expr

155+ let expr' = processTransGraphAtomExpr expr

166 AttributeEqualityPredicate attrName <$> expr'

156 AttributeEqualityPredicate attrName <$> expr'

167

157

168−evalTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr

158+processTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr

169−evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) = do

159+processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) = do

170− AttributeExtendTupleExpr attrName <$> evalTransGraphAtomExpr expr

160+ AttributeExtendTupleExpr attrName <$> processTransGraphAtomExpr expr

171

161

172−evalTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr

162+processTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr

173−evalTransGraphAttributeExpr (AttributeAndTypeNameExpr attrName tCons tLookup) =

163+processTransGraphAttributeExpr (AttributeAndTypeNameExpr attrName tCons tLookup) =

174 AttributeAndTypeNameExpr attrName tCons <$> findTransId tLookup

164 AttributeAndTypeNameExpr attrName tCons <$> findTransId tLookup

175−evalTransGraphAttributeExpr (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)

165+processTransGraphAttributeExpr (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)

176−

166+

177−evalTransAttributeNames :: TransGraphAttributeNames -> TransGraphEvalMonad GraphRefAttributeNames

167+processTransGraphAttributeNames :: TransGraphAttributeNames -> TransGraphEvalMonad GraphRefAttributeNames

178−evalTransAttributeNames (AttributeNames names) = pure (AttributeNames names)

168+processTransGraphAttributeNames (AttributeNames names) = pure (AttributeNames names)

179−evalTransAttributeNames (InvertedAttributeNames names) = pure (InvertedAttributeNames names)

169+processTransGraphAttributeNames (InvertedAttributeNames names) = pure (InvertedAttributeNames names)

180−evalTransAttributeNames (UnionAttributeNames namesA namesB) = do

170+processTransGraphAttributeNames (UnionAttributeNames namesA namesB) = do

181− nA <- evalTransAttributeNames namesA

171+ nA <- processTransGraphAttributeNames namesA

182− nB <- evalTransAttributeNames namesB

172+ nB <- processTransGraphAttributeNames namesB

183 pure (UnionAttributeNames nA nB)

173 pure (UnionAttributeNames nA nB)

184−evalTransAttributeNames (IntersectAttributeNames namesA namesB) = do

174+processTransGraphAttributeNames (IntersectAttributeNames namesA namesB) = do

185− nA <- evalTransAttributeNames namesA

175+ nA <- processTransGraphAttributeNames namesA

186− nB <- evalTransAttributeNames namesB

176+ nB <- processTransGraphAttributeNames namesB

187 pure (IntersectAttributeNames nA nB)

177 pure (IntersectAttributeNames nA nB)

188−evalTransAttributeNames (RelationalExprAttributeNames expr) = do

178+processTransGraphAttributeNames (RelationalExprAttributeNames expr) = do

189− evaldExpr <- evalTransGraphRelationalExpr expr

179+ evaldExpr <- processTransGraphRelationalExpr expr

190 pure (RelationalExprAttributeNames evaldExpr)

180 pure (RelationalExprAttributeNames evaldExpr)

src/lib/ProjectM36/Transaction/Persist.hs−3

@@ -18,9 +18,6 @@ import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)

18import Control.Exception

19import GHC

20import GHC.Paths

21−import Codec.Compression.GZip

22−import qualified Data.ByteString as BS

23−import qualified Data.ByteString.Lazy as BSL

25getDirectoryNames :: FilePath -> IO [FilePath]

22getDirectoryNames :: FilePath -> IO [FilePath]

26getDirectoryNames path =

23getDirectoryNames path =

src/lib/ProjectM36/TransactionGraph.hs+9−10

@@ -10,7 +10,6 @@ import ProjectM36.Tuple

10import ProjectM36.RelationalExpression

11import ProjectM36.TransactionGraph.Merge

12import qualified ProjectM36.DisconnectedTransaction as Discon

13−import qualified ProjectM36.TransactionDiffs as TD

15import qualified Data.Vector as V

14import qualified Data.Vector as V

16import qualified ProjectM36.Attribute as A

15import qualified ProjectM36.Attribute as A

@@ -117,7 +116,7 @@ addBranch stamp' newId newBranchName branchPointId graph = do

117

116

118--adds a disconnected transaction to a transaction graph at some head

117--adds a disconnected transaction to a transaction graph at some head

119addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

118addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

120−addDisconnectedTransaction stamp' newId headName discon@(DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName newTrans

119+addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName newTrans

121 where

120 where

122 newTrans = Transaction newId (TI.singleParent parentId stamp') schemas'

121 newTrans = Transaction newId (TI.singleParent parentId stamp') schemas'

123

122

@@ -332,16 +331,16 @@ validateHeadName headName graph (t1, t2) =

332

331

333-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal.

332-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal.

334subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph

333subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph

335−subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do

334+subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do

336− let currentid = transactionId currentTrans

335+ let currentid = transactionId currentTrans'

337 goalid = transactionId goalTrans

336 goalid = transactionId goalTrans

338− if currentTrans == goalTrans then

337+ if currentTrans' == goalTrans then

339 Right (TransactionGraph resultHeads traverseSet) -- add filter

338 Right (TransactionGraph resultHeads traverseSet) -- add filter

340 --catch root transaction to improve error?

339 --catch root transaction to improve error?

341 else do

340 else do

342− currentTransChildren <- childTransactions currentTrans origGraph

341+ currentTransChildren <- childTransactions currentTrans' origGraph

343− let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren

342+ let searchChildren = S.difference (S.insert currentTrans' traverseSet) currentTransChildren

344− searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)

343+ searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans' traverseSet)

345 childSearches = map searchChild (S.toList searchChildren)

344 childSearches = map searchChild (S.toList searchChildren)

346 errors = lefts childSearches

345 errors = lefts childSearches

347 pathsFound = rights childSearches

346 pathsFound = rights childSearches

@@ -350,11 +349,11 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans trave

350 unless (null realErrors) (Left (head realErrors))

349 unless (null realErrors) (Left (head realErrors))

351 -- if no paths found, search the parent

350 -- if no paths found, search the parent

352 if null pathsFound then

351 if null pathsFound then

353− case oneParent currentTrans of

352+ case oneParent currentTrans' of

354 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)

353 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)

355 Left err -> Left err

354 Left err -> Left err

356 Right currentTransParent ->

355 Right currentTransParent ->

357− subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)

356+ subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans' traverseSet)

358 else -- we found a path

357 else -- we found a path

359 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))

358 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))

360 where

359 where

src/lib/ProjectM36/TransactionGraph/Merge.hs+2−2

@@ -35,7 +35,7 @@ unionMergeRelation prefer relA relB = case relA `union` relB of

36--try to execute unions against the relvars contents -- if a relvar only appears in one context, include it

37unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> Either MergeError RelationVariables

38−unionMergeRelVars prefer relvarsA relvarsB = do

38+unionMergeRelVars _ relvarsA relvarsB = do

39 let allNames = S.toList (S.union (M.keysSet relvarsA) (M.keysSet relvarsB))

40 foldM (\acc name -> do

41 mergedRel <- do

@@ -43,7 +43,7 @@ unionMergeRelVars prefer relvarsA relvarsB = do

43 lookupA = findRel relvarsA

44 lookupB = findRel relvarsB

45 case (lookupA, lookupB) of

46− (Just relA, Just relB) -> unimplemented

46+ (Just _, Just _) -> unimplemented

47 --unionMergeRelation prefer relA relB

48 (Nothing, Just relB) -> pure relB

49 (Just relA, Nothing) -> pure relA

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

@@ -1,6 +1,5 @@

1module ProjectM36.TransactionGraph.Persist where

2import ProjectM36.Error

3−import ProjectM36.TransactionGraph

4import ProjectM36.Transaction

3import ProjectM36.Transaction

5import ProjectM36.Transaction.Persist

4import ProjectM36.Transaction.Persist

6import ProjectM36.RelationalExpression

5import ProjectM36.RelationalExpression