5780162 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP compilation checkpoint

commit5780162d31259921d06497d14011c74203abfbad authorAgentM <agentm@themactionfaction.com> dateFri 20 Dec 2019, 10:03 (7 years ago) parent1656f99

16 files changed+331−248

compare with master

unifiedsplit

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

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

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

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

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

44module ProjectM36.Base where

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

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

217217 --Evaluate relationalExpr with scoped views

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

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

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

220220

221221instance Binary RelationalExpr

222222

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

313313

314314type GraphRefDatabaseContextExpr = DatabaseContextExprBase TransactionId

315315

316+instance Binary GraphRefDatabaseContextExpr

317+

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

317319data DatabaseContextExprBase a =

318320 NoOperation |

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

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

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

375377 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)

377379

378380instance Binary RestrictionPredicateExpr

379381

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

443445 FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |

444446 RelationAtomExpr (RelationalExprBase a) |

445447 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

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

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

447449

448450instance Binary AtomExpr

449451

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

451453data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

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

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

453455

454456type ExtendTupleExpr = ExtendTupleExprBase ()

455457type GraphRefExtendTupleExpr = ExtendTupleExprBase TransactionId

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

500502 UnionAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

501503 IntersectAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

502504 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)

504506

505507type AttributeNames = AttributeNamesBase ()

506508

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

520522-- | Create attributes dynamically.

521523data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

522524 NakedAttributeExpr Attribute

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

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

524526

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

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

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

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

528530

529531instance Binary TupleExpr

530532

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

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

4848 RelationalExprBase(..),

4949 DatabaseContextExprBase(..),

5050 DatabaseContextExpr,

51− DatabaseContextIOExpr(..),

51+ DatabaseContextIOExprBase(..),

52+ DatabaseContextIOExpr,

5253 Attribute(..),

5354 MergeStrategy(..),

5455 attributesFromList,

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

121122import qualified ProjectM36.Transaction as Trans

122123import ProjectM36.TransactionGraph.Persist

123124import ProjectM36.Attribute

124−import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr)

125+import ProjectM36.TransGraphRelationalExpression as TGRE (TransGraphRelationalExpr)

125126import ProjectM36.Persist (DiskSync(..))

126127import ProjectM36.FileLock

127128import ProjectM36.Notifications

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

130131import ProjectM36.Relation (typesAsRelation)

131132import ProjectM36.ScriptSession (initScriptSession, ScriptSession)

132133import qualified ProjectM36.Relation as R

133−import qualified ProjectM36.DatabaseContext as DBC

134134import Control.Exception.Base

135135import GHC.Conc.Sync

136136

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

594594 Schema.processDatabaseContextExprInSchema schema expr

595595 case expr' of

596596 Left err -> pure (Left err)

597− Right expr'' ->

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

599− Left err -> pure (Left err)

600− Right newState ->

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

602− pure (Right ())

603− else do

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

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

606− newSchemas = Schemas context' newSubschemas

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

608− StmMap.insert newSession sessionId sessions

609− pure (Right ())

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

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

603+ Left err -> pure (Left err)

604+ Right newState ->

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

606+ pure (Right ())

607+ else do

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

609+ context' = RE.dbc_context newState

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

611+ newSchemas = Schemas context' newSubschemas

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

613+ StmMap.insert newSession sessionId sessions

614+ pure (Right ())

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

611616

612617-- | 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

648653 case eSession of

649654 Left err -> pure (Left err)

650655 Right session -> do

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

656+ graph <- readTVarIO (ipTransactionGraph conf)

657+ let env = RE.DatabaseContextIOEvalEnv transId graph scriptSession

658+ transId = Sess.parentId session

659+ context = Sess.concreteDatabaseContext session

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

652661 case res of

653662 Left err -> pure (Left err)

654− Right context' -> do

663+ Right newState -> do

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

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

657666 newSession = Session newDiscon (Sess.schemaName session)

667+ context' = RE.dbc_context newState

658668 atomically $ StmMap.insert newSession sessionId sessions

659669 pure (Right ())

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

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

674684-}

675685

676686-- process notifications for commits

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

678−executeCommitExprSTM_ oldContext newContext nodes = do

687+executeCommitExprSTM_

688+ :: TransactionId

689+ -> TransactionGraph

690+ -> DatabaseContext

691+ -> DatabaseContext

692+ -> ClientNodes

693+ -> STM (EvaluatedNotifications, ClientNodes)

694+executeCommitExprSTM_ transId graph oldContext newContext nodes = do

679695 let nots = notifications oldContext

680− fireNots = notificationChanges nots oldContext newContext

696+ fireNots = notificationChanges nots transId graph oldContext newContext

681697 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+

683700 mkEvaldNot notif = EvaluatedNotification { notification = notif,

684701 reportOldRelation = evalInContext (reportOldExpr notif) oldContext,

685702 reportNewRelation = evalInContext (reportNewExpr notif) newContext}

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

705722 Left err -> pure (Left err)

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

707724 --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')]

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

710727{-

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

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

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

786803 let graphTvar = ipTransactionGraph conf

787804 graph <- readTVar graphTvar

788− case evalTransGraphRelationalExpr tgraphExpr graph of

789− Left err -> pure (Left err)

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

805+ pure $ force $ optimizeAndEvalTransGraphRelationalExpr graph tgraphExpr

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

791807 Left err -> pure (Left err)

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

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

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

794810

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

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

857873 Schema.processRelationalExprInSchema schema relExpr

858874 case processed of

859875 Left err -> pure (Left err)

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

876+ Right relExpr' -> do

877+ let transId = Sess.parentId session

878+ graph <- readTVar (ipTransactionGraph conf)

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

861880

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

863882

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

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

891910

892911-- | 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)

894913planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do

895914 let sessions = ipSessions conf

896915 atomically $ do

916+ graph <- readTVar (ipTransactionGraph conf)

897917 eSession <- sessionAndSchema sessionId sessions

898918 case eSession of

899919 Left err -> pure $ Left err

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

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

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

903− pure (Right dbExpr)

920+ Right (session, _) ->

921+ if schemaName session == defaultSchemaName then do

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)

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-}

927+ pure (Left NonConcreteSchemaPlanError)

904928

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

906930

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

927951relationVariablesAsRelation sessionId (InProcessConnection conf) = do

928952 let sessions = ipSessions conf

929953 atomically $ do

954+ graph <- readTVar (ipTransactionGraph conf)

930955 eSession <- sessionAndSchema sessionId sessions

931956 case eSession of

932957 Left err -> pure (Left err)

933958 Right (session, schema) -> do

934959 let context = Sess.concreteDatabaseContext session

935960 if Sess.schemaName session == defaultSchemaName then

936− pure $ R.relationVariablesAsRelation (relationVariables context)

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

937962 else

938963 case Schema.relationVariablesInSchema schema context of

939964 Left err -> pure (Left err)

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

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

941966

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

943968

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

9831008 eSession <- sessionForSessionId sessionId sessions

9841009 case eSession of

9851010 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

9871012 Left err -> pure (Left err)

9881013 Right parentTrans -> case headNameForTransaction parentTrans graph of

9891014 Nothing -> pure (Left UnknownHeadError)

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

10951120 writeTVar graphTvar graph'

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

10971122 StmMap.insert newSession sessionId sessions

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

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

10991124 Left err -> pure $ Left err

11001125 Right previousTrans ->

11011126 if not (Prelude.null transactionIdsToPersist) then do

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

1127+ let transId = Sess.parentId newSession

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

11031129 nodesToNotify <- stmSetToList nodes

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

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

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

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

1717

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

1919databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

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

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

2121 where

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

2323 incDepsExprs :: [DatabaseContextExpr]

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

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

33import ProjectM36.Base

44import ProjectM36.DatabaseContextFunctionError

55import ProjectM36.Error

6−import Control.Monad.State

7−import Control.Monad.Trans.Reader

6+import ProjectM36.StaticOptimizer

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

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

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

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

9+executeDatabaseContextExpr expr transId graph context' =

10+ case run of

11+ Right st -> pure (dbc_context st)

12+ Left err -> error (show err)

13+ where

14+ env = mkDatabaseContextEvalEnv transId graph

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

1316

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

15−executeRelationalExpr expr context tid graph = do

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

17− evalGraphRefRelationalExpr gfExpr graph

18+executeRelationalExpr expr context transId graph =

19+ run

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)

9696 | SchemaCreationError SchemaError

9797

9898 | ImproperDatabaseStateError

99+

100+ | NonConcreteSchemaPlanError

99101

100102 | MultipleErrors [RelationalError]

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

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

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

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

33import ProjectM36.Base

44import ProjectM36.Error

5−import qualified ProjectM36.Attribute as A

6−import Control.Monad.Trans.Except

5+import qualified Data.Set as S

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

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

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

2019

2120

2221-}

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

33import ProjectM36.Error

44import ProjectM36.RelationalExpression

55import ProjectM36.StaticOptimizer

6−import Control.Monad.Trans.Reader

76import qualified Data.Map as M

87import Data.Either (isRight)

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

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

44import qualified Data.HashSet as HS

55import Control.Monad

66import qualified Data.Vector as V

7−import qualified Data.Map as M

8−import ProjectM36.AtomType

97import ProjectM36.Base

108import ProjectM36.Tuple

119import qualified ProjectM36.Attribute as A

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

304302 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

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

306304 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))]

321305

322306-- | 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.

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

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

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

331315

332316tuplesList :: 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

1818import qualified Data.Map as M

1919import qualified Data.HashSet as HS

2020import 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

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

23−import Control.Monad (forM)

2423import Control.Exception

2524import Data.Maybe

2625import Data.Either

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

146145dbcGraph = dce_graph <$> RWS.ask

147146

148147dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv

149−dbcRelationalExprEnv = do

150− tid <- dbcTransId

151− graph <- dbcGraph

148+dbcRelationalExprEnv =

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

153150

154151getStateContext :: DatabaseContextEvalMonad DatabaseContext

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

161158

162159type RelationalExprState a = Reader RelationalExprEnv a

163160

161+type GraphRefRelationalExprR a = Reader TransactionGraph a

162+

164163envContext :: RelationalExprEnv -> DatabaseContext

165164envContext = re_context

166165

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

375374evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName

376375

377376evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

378− relExprEnv <- dbcRelationalExprEnv

377+ graph <- re_graph <$> dbcRelationalExprEnv

379378 context <- getStateContext

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

381380 case existingRelVar of

382381 Nothing -> do

383382 setRelVar relVarName expr

384383 Just existingRel -> do

385− let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) relExprEnv

386− eNewExprType = runReader (typeForGraphRefRelationalExpr expr) relExprEnv

384+ let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) graph

385+ eNewExprType = runReader (typeForGraphRefRelationalExpr expr) graph

387386 case eExpectedType of

388387 Left err -> dbErr err

389388 Right expectedType ->

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

408407 setRelVar relVarName (Restrict (NotPredicate predicate) rv)

409408

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

411−evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred) = do

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

412411 context <- getStateContext

413412 transId <- dbcTransId

414413 reEnv <- dbcRelationalExprEnv

415414 let relVarMap = relationVariables context

416415 case M.lookup relVarName relVarMap of

417416 Nothing -> dbErr (RelVarNotDefinedError relVarName)

418− Just existingRvExpr -> do

419− let unrestrictedPortion = Restrict (NotPredicate pred) rv

417+ Just _ -> do

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

420419 rv = RelationVariable relVarName transId

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

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

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

424− restrictedPortion = Restrict pred

423+ restrictedPortion = Restrict pred'

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

426425 let procAtomExpr = runReader (processAtomExpr atomExpr) reEnv in

427426 updateAttr oldname procAtomExpr accum

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

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

503502 putStateContext $ currentContext { typeConstructorMapping = newTypes }

504503

505−evalGraphRefDatabaseContextExpr (MultipleExpr exprs) = do

504+evalGraphRefDatabaseContextExpr (MultipleExpr _) = do

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

507506 unimplemented

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

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

577576

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

579578

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+

580588requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)

581589requireScriptSession = do

582590 env <- RWS.ask

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

710718 case existingRelVar of

711719 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

712720 Just existingRel -> do

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

721+ case runReader (typeForGraphRefRelationalExpr existingRel) graph of

714722 Left err -> pure (Left err)

715723 Right relType -> do

716724 let expectedAttributes = attributes relType

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

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

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

772780 gfExpr <- processRelationalExpr expr

773− typeForGraphRefRelationalExpr gfExpr

781+ graph <- re_graph <$> askEnv

782+ pure $ runReader (typeForGraphRefRelationalExpr gfExpr) graph

774783

775784--returns a database context with all tuples removed

776785--this is useful for type checking and optimization

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

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

11231132

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

1134+--evalGraphRefRelationalExpr (MakeRelationaFromExprs

11251135evalGraphRefRelationalExpr (RelationVariable name tid) graph = do

11261136 ctx <- dbContextForTransId tid graph

11271137 case M.lookup name (relationVariables ctx) of

11281138 Nothing -> Left (RelVarNotDefinedError name)

11291139 Just rv -> evalGraphRefRelationalExpr rv graph

11301140

1141+

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

11321143dbContextForTransId tid graph = do

11331144 trans <- transactionForId tid graph

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

11601171processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =

11611172 AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr

11621173

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

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

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

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

11661177typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =

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

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

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

11731184typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

1174− eTrans <- currentTrans

1185+ graph <- R.ask

1186+ let eTrans = transactionForId tid graph

11751187 case eTrans of

11761188 Left err -> pure (Left err)

11771189 Right trans -> do

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

11891201 Left err -> Left err

11901202 Right projectionAttrs -> project projectionAttrs exprType

11911203

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

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

11931205evalGraphRefAttributeNames attrNames expr = do

11941206 eExprType <- typeForGraphRefRelationalExpr expr

11951207 case eExprType of

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

12531265processTupleExpr (TupleExpr tMap) =

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

12551267

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

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

12571269evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

1258− graph <- re_graph <$> askEnv

1270+ graph <- R.ask

12591271 case transactionForId tid graph of

12601272 Left err -> pure (Left err)

12611273 Right trans -> do

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

13671379processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =

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

13691381

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

8383 ret <- timeoutOrDie ti (inclusionDependencies sessionId conn)

8484 reply ret conn

8585

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

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

8787handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do

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

8989 reply ret conn

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

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

33import ProjectM36.GraphRefRelationalExpr

44import ProjectM36.Relation

55import ProjectM36.RelationalExpression

6+import ProjectM36.TransGraphRelationalExpression as TGRE

67import ProjectM36.Error

8+import ProjectM36.Transaction

79import qualified ProjectM36.Attribute as A

810import qualified ProjectM36.AttributeNames as AS

911import ProjectM36.TupleSet

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

1113import Control.Monad.Trans.Reader

1214import Control.Monad.Trans.Except

1315import Data.Functor.Identity

14−import Data.Either (rights, lefts)

15−import Control.Monad.Trans.Reader

1616import qualified Data.Map as M

1717import qualified Data.Set as S

1818

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

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

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

2323

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

25+

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

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

2628optimizeAndEvalRelationalExpr env expr = do

2729 let gfExpr = runReader (processRelationalExpr expr) env

28− optExpr <- runStaticOptimizerMonad env (fullOptimizeGraphRefRelationalExpr gfExpr)

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

2931 evalGraphRefRelationalExpr optExpr (re_graph env)

3032

3133optimizeAndEvalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContextEvalMonad ()

3234optimizeAndEvalDatabaseContextExpr expr = do

3335 env <- dbcRelationalExprEnv

3436 let gfExpr = runReader (processDatabaseContextExpr expr) env

35− eOptExpr = runStaticOptimizerMonad env (optimizeDatabaseContextExpr gfExpr)

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

3638 case eOptExpr of

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

3840 Right optExpr -> evalGraphRefDatabaseContextExpr optExpr

3941

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+

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

4149optimizeAndEvalDatabaseContextIOExpr expr = do

4250 reEnv <- getDBCIORelationalExprEnv

4351 let gfExpr = runReader (processDatabaseContextIOExpr expr) reEnv

44− optExpr <- runStaticOptimizerMonad reEnv (optimizeDatbaseContextIOExpr gfExpr)

45− evalGraphRefDatabaseContextIOExpr optExpr

52+ eOptExpr = runStaticOptimizerMonad reEnv (optimizeDatabaseContextIOExpr gfExpr)

53+ case eOptExpr of

54+ Left err -> pure (Left err)

55+ Right optExpr ->

56+ evalGraphRefDatabaseContextIOExpr optExpr

4657

4758

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

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

5061

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

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

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

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

5364

54−fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> StaticOptimizerMonad GraphRefRelationalExpr

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+

69+fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

5570fullOptimizeGraphRefRelationalExpr expr = do

5671 optExpr <- optimizeGraphRefRelationalExpr expr

5772 let optExpr' = applyStaticRestrictionPushdown (applyStaticRestrictionCollapse optExpr)

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

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

6176

6277--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

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

6580

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

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

130145

131146--remove restriction of nothing

132147optimizeGraphRefRelationalExpr (Restrict predicate expr) = do

133− env <- ask

148+ graph <- ask

134149 optimizedPredicate <- applyStaticPredicateOptimization predicate

135150 case optimizedPredicate of

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

137152 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

139154 case attributesRel of

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

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

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

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

153168

154169-- database context expr

155−optimizeDatabaseContextExpr :: GraphRefDatabaseContextExpr -> StaticOptimizerMonad GraphRefDatabaseContextExpr

156−optimizeDatabaseContextExpr x@NoOperation = pure x

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

170+optimizeGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> GraphRefStaticOptimizerMonad GraphRefDatabaseContextExpr

171+optimizeGraphRefDatabaseContextExpr x@NoOperation = pure x

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

158173

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

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

160175

161−optimizeDatabaseContextExpr (Assign name expr) = do

176+optimizeGraphRefDatabaseContextExpr (Assign name expr) = do

162177 optExpr <- optimizeGraphRefRelationalExpr expr

163178 pure $ Assign name optExpr

164179

165−optimizeDatabaseContextExpr (Insert targetName expr) = do

180+optimizeGraphRefDatabaseContextExpr (Insert targetName expr) = do

166181 optimizedExpr <- fullOptimizeGraphRefRelationalExpr expr

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

168183 pure NoOperation

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

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

174189 _ -> pure (Insert targetName optimizedExpr)

175190

176−optimizeDatabaseContextExpr (Delete name predicate) =

191+optimizeGraphRefDatabaseContextExpr (Delete name predicate) =

177192 Delete name <$> applyStaticPredicateOptimization predicate

178193

179−optimizeDatabaseContextExpr (Update name upmap predicate) =

194+optimizeGraphRefDatabaseContextExpr (Update name upmap predicate) =

180195 Update name upmap <$> applyStaticPredicateOptimization predicate

181196

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

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

183198

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

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

185200

186−optimizeDatabaseContextExpr (AddNotification name triggerExpr resultOldExpr resultNewExpr) =

201+optimizeGraphRefDatabaseContextExpr (AddNotification name triggerExpr resultOldExpr resultNewExpr) =

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

188203 pure (AddNotification name triggerExpr resultOldExpr resultNewExpr)

189204

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

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

191206

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

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

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

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

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

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

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

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

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

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

197212

198213--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

199214

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

201216--for multiple expressions, we must evaluate

202−applyStaticDatabaseOptimization (MultipleExpr exprs) = do

217+optimizeGraphRefDatabaseContextExpr (MultipleExpr _) = do

203218 --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

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

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

219+ unimplemented

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

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

206222

207223

208−applyStaticPredicateOptimization :: GraphRefRestrictionPredicateExpr -> StaticOptimizerMonad GraphRefRestrictionPredicateExpr

224+applyStaticPredicateOptimization :: GraphRefRestrictionPredicateExpr -> GraphRefStaticOptimizerMonad GraphRefRestrictionPredicateExpr

209225applyStaticPredicateOptimization predi = do

210226 optPred <- case predi of

211227-- where x and x => where x

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

298314isStaticAtomExpr RelationAtomExpr{} = False

299315

300316--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

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

303− env <- ask

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

305− eProjType = typeForExpr expr

306− eTypeA = typeForExpr exprA

307− eTypeB = typeForExpr exprB

308− liftErr = lift . except . Left

309− case eProjType of

310− Left err -> liftErr err

311− Right projType ->

312− case eTypeA of

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

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

325+ eProjType = typeForExpr expr

326+ eTypeA = typeForExpr exprA

327+ eTypeB = typeForExpr exprB

328+ liftErr = lift . except . Left

329+ case eProjType of

330+ Left err -> liftErr err

331+ Right projType ->

332+ case eTypeA of

313333 Left err -> liftErr err

314334 Right typeA ->

315335 case eTypeB of

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

327347 Nothing -> -- this optimization does not apply

328348 pure expr

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

350+ --lookup transaction

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

330352 --scan inclusion dependencies for a foreign key relationship

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

332− let fkConstraint = foldM isFkConstraint False incDeps

353+ let incDeps = inclusionDependencies commonContext

354+ commonContext = concreteDatabaseContext trans

355+ reEnv = mkRelationalExprEnv commonContext commonTransId graph

356+ fkConstraint = foldM isFkConstraint False incDeps

333357 --search for matching fk constraint

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

335− let gfSubAttrNames = runReader (processAttributeNames subAttrNames) env

336− gfSubRv = runReader (processRelationalExpr subrv) env

337− gfSuperRv = runReader (processRelationalExpr superrv) env

359+ let gfSubAttrNames = runReader (processAttributeNames subAttrNames) reEnv

360+ gfSubRv = runReader (processRelationalExpr subrv) reEnv

361+ gfSuperRv = runReader (processRelationalExpr superrv) reEnv

338362

339− case runReader (evalGraphRefAttributeNames gfSubAttrNames expr) env of

363+ case runReader (evalGraphRefAttributeNames gfSubAttrNames expr) graph of

340364 Left _ -> pure acc

341365 Right subAttrNameSet ->

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

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

438462 Extend n sub ->

439463 Extend n (applyStaticRestrictionPushdown sub)

440464

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 @@

44module ProjectM36.TransGraphRelationalExpression where

55import ProjectM36.Base

66import ProjectM36.TransactionGraph

7−import ProjectM36.Transaction

8−import ProjectM36.GraphRefRelationalExpr

9−import ProjectM36.RelationalExpression hiding (liftE)

107import ProjectM36.Error

11−import ProjectM36.Tuple

12−import ProjectM36.AtomType

138import qualified Data.Map as M

149import Control.Monad.Trans.Reader

1510import Control.Monad.Trans.Class

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

4439

4540type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

4641

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

48− graph :: TransactionGraph

49− }

42+data TransGraphEvalEnv = TransGraphEvalEnv {

43+ tge_graph :: TransactionGraph

44+ }

5045

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

5247

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

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

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

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

5550

5651liftE :: Either RelationalError a -> TransGraphEvalMonad a

5752liftE = lift . except

5853

59−

60−askTid :: TransGraphEvalMonad TransactionId

61−askTid = transId <$> ask

62−

6354askGraph :: TransGraphEvalMonad TransactionGraph

64−askGraph = graph <$> ask

55+askGraph = tge_graph <$> ask

6556

6657findTransId :: TransactionIdLookup -> TransGraphEvalMonad TransactionId

6758findTransId tlook = transactionId <$> findTrans tlook

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

7263 liftE $ lookupTransaction graph tlook

7364

7465-- 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

76−evalTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

77− tupleExprs' <- mapM evalTransGraphTupleExpr tupleExprs

66+processTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransGraphEvalMonad GraphRefRelationalExpr

67+processTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

68+ tupleExprs' <- mapM processTransGraphTupleExpr tupleExprs

7869 case mAttrExprs of

7970 Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')

8071 Just attrExprs -> do

81− attrExprs' <- mapM evalTransGraphAttributeExpr attrExprs

72+ attrExprs' <- mapM processTransGraphAttributeExpr attrExprs

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

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

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

85−evalTransGraphRelationalExpr (RelationVariable rvname transLookup) =

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

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

76+processTransGraphRelationalExpr (RelationVariable rvname transLookup) =

8677 RelationVariable rvname <$> findTransId transLookup

87−evalTransGraphRelationalExpr (Project transAttrNames expr) =

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

89−evalTransGraphRelationalExpr (Union exprA exprB) =

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

91−evalTransGraphRelationalExpr (Join exprA exprB) =

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

93−evalTransGraphRelationalExpr (Rename attrName1 attrName2 expr) =

94− Rename attrName1 attrName2 <$> evalTransGraphRelationalExpr expr

95−evalTransGraphRelationalExpr (Difference exprA exprB) =

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

97−evalTransGraphRelationalExpr (Group transAttrNames attrName expr) =

78+processTransGraphRelationalExpr (Project transAttrNames expr) =

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

80+processTransGraphRelationalExpr (Union exprA exprB) =

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

82+processTransGraphRelationalExpr (Join exprA exprB) =

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

84+processTransGraphRelationalExpr (Rename attrName1 attrName2 expr) =

85+ Rename attrName1 attrName2 <$> processTransGraphRelationalExpr expr

86+processTransGraphRelationalExpr (Difference exprA exprB) =

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

88+processTransGraphRelationalExpr (Group transAttrNames attrName expr) =

9889 Group <$>

99− evalTransAttributeNames transAttrNames <*>

90+ processTransGraphAttributeNames transAttrNames <*>

10091 pure attrName <*>

101− evalTransGraphRelationalExpr expr

102−evalTransGraphRelationalExpr (Ungroup attrName expr) =

103− Ungroup attrName <$> evalTransGraphRelationalExpr expr

104−evalTransGraphRelationalExpr (Restrict predicateExpr expr) =

92+ processTransGraphRelationalExpr expr

93+processTransGraphRelationalExpr (Ungroup attrName expr) =

94+ Ungroup attrName <$> processTransGraphRelationalExpr expr

95+processTransGraphRelationalExpr (Restrict predicateExpr expr) =

10596 Restrict <$> evalTransGraphRestrictionPredicateExpr predicateExpr <*>

106− evalTransGraphRelationalExpr expr

107−evalTransGraphRelationalExpr (Equals exprA exprB) = do

108− exprA' <- evalTransGraphRelationalExpr exprA

109− exprB' <- evalTransGraphRelationalExpr exprB

97+ processTransGraphRelationalExpr expr

98+processTransGraphRelationalExpr (Equals exprA exprB) = do

99+ exprA' <- processTransGraphRelationalExpr exprA

100+ exprB' <- processTransGraphRelationalExpr exprB

110101 pure (Equals exprA' exprB')

111−evalTransGraphRelationalExpr (NotEquals exprA exprB) = do

112− exprA' <- evalTransGraphRelationalExpr exprA

113− exprB' <- evalTransGraphRelationalExpr exprB

102+processTransGraphRelationalExpr (NotEquals exprA exprB) = do

103+ exprA' <- processTransGraphRelationalExpr exprA

104+ exprB' <- processTransGraphRelationalExpr exprB

114105 pure (NotEquals exprA' exprB')

115−evalTransGraphRelationalExpr (Extend extendExpr expr) = do

116− extendExpr' <- evalTransGraphExtendTupleExpr extendExpr

117− expr' <- evalTransGraphRelationalExpr expr

106+processTransGraphRelationalExpr (Extend extendExpr expr) = do

107+ extendExpr' <- processTransGraphExtendTupleExpr extendExpr

108+ expr' <- processTransGraphRelationalExpr expr

118109 pure (Extend extendExpr' expr')

119−evalTransGraphRelationalExpr (With views expr) = do

110+processTransGraphRelationalExpr (With views expr) = do

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

121− vexpr' <- evalTransGraphRelationalExpr vexpr

112+ vexpr' <- processTransGraphRelationalExpr vexpr

122113 pure (vname, vexpr')

123114 ) views

124− expr' <- evalTransGraphRelationalExpr expr

115+ expr' <- processTransGraphRelationalExpr expr

125116 pure (With evaldViews expr')

126117

127−evalTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr

128−evalTransGraphTupleExpr (TupleExpr attrMap) = do

129− graph <- askGraph

118+processTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr

119+processTransGraphTupleExpr (TupleExpr attrMap) = do

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

131− aExpr <- evalTransGraphAtomExpr atomExpr

121+ aExpr <- processTransGraphAtomExpr atomExpr

132122 pure (attrName, aExpr)

133123 ) (M.toList attrMap)

134124 TupleExpr . M.fromList <$> attrAssoc

135125

136−evalTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr

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

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

139−evalTransGraphAtomExpr (FunctionAtomExpr funcName args tLookup) =

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

141−evalTransGraphAtomExpr (RelationAtomExpr expr) =

142− RelationAtomExpr <$> evalTransGraphRelationalExpr expr

143−evalTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =

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

126+processTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr

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

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

129+processTransGraphAtomExpr (FunctionAtomExpr funcName args tLookup) =

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

131+processTransGraphAtomExpr (RelationAtomExpr expr) =

132+ RelationAtomExpr <$> processTransGraphRelationalExpr expr

133+processTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =

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

145135evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr

146136evalTransGraphRestrictionPredicateExpr TruePredicate = pure TruePredicate

147137evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) = do

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

156146 let expr' = evalTransGraphRestrictionPredicateExpr expr

157147 NotPredicate <$> expr'

158148evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) = do

159− let expr' = evalTransGraphRelationalExpr expr

149+ let expr' = processTransGraphRelationalExpr expr

160150 RelationalExprPredicate <$> expr'

161151evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) = do

162− let expr' = evalTransGraphAtomExpr expr

152+ let expr' = processTransGraphAtomExpr expr

163153 AtomExprPredicate <$> expr'

164154evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) = do

165− let expr' = evalTransGraphAtomExpr expr

155+ let expr' = processTransGraphAtomExpr expr

166156 AttributeEqualityPredicate attrName <$> expr'

167157

168−evalTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr

169−evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) = do

170− AttributeExtendTupleExpr attrName <$> evalTransGraphAtomExpr expr

158+processTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr

159+processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) = do

160+ AttributeExtendTupleExpr attrName <$> processTransGraphAtomExpr expr

171161

172−evalTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr

173−evalTransGraphAttributeExpr (AttributeAndTypeNameExpr attrName tCons tLookup) =

162+processTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr

163+processTransGraphAttributeExpr (AttributeAndTypeNameExpr attrName tCons tLookup) =

174164 AttributeAndTypeNameExpr attrName tCons <$> findTransId tLookup

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

176−

177−evalTransAttributeNames :: TransGraphAttributeNames -> TransGraphEvalMonad GraphRefAttributeNames

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

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

180−evalTransAttributeNames (UnionAttributeNames namesA namesB) = do

181− nA <- evalTransAttributeNames namesA

182− nB <- evalTransAttributeNames namesB

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

166+

167+processTransGraphAttributeNames :: TransGraphAttributeNames -> TransGraphEvalMonad GraphRefAttributeNames

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

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

170+processTransGraphAttributeNames (UnionAttributeNames namesA namesB) = do

171+ nA <- processTransGraphAttributeNames namesA

172+ nB <- processTransGraphAttributeNames namesB

183173 pure (UnionAttributeNames nA nB)

184−evalTransAttributeNames (IntersectAttributeNames namesA namesB) = do

185− nA <- evalTransAttributeNames namesA

186− nB <- evalTransAttributeNames namesB

174+processTransGraphAttributeNames (IntersectAttributeNames namesA namesB) = do

175+ nA <- processTransGraphAttributeNames namesA

176+ nB <- processTransGraphAttributeNames namesB

187177 pure (IntersectAttributeNames nA nB)

188−evalTransAttributeNames (RelationalExprAttributeNames expr) = do

189− evaldExpr <- evalTransGraphRelationalExpr expr

178+processTransGraphAttributeNames (RelationalExprAttributeNames expr) = do

179+ evaldExpr <- processTransGraphRelationalExpr expr

190180 pure (RelationalExprAttributeNames evaldExpr)

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

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

1818import Control.Exception

1919import GHC

2020import GHC.Paths

21−import Codec.Compression.GZip

22−import qualified Data.ByteString as BS

23−import qualified Data.ByteString.Lazy as BSL

2421

2522getDirectoryNames :: FilePath -> IO [FilePath]

2623getDirectoryNames path =

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

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

1010import ProjectM36.RelationalExpression

1111import ProjectM36.TransactionGraph.Merge

1212import qualified ProjectM36.DisconnectedTransaction as Discon

13−import qualified ProjectM36.TransactionDiffs as TD

1413

1514import qualified Data.Vector as V

1615import qualified ProjectM36.Attribute as A

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

117116

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

119118addDisconnectedTransaction :: 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

121120 where

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

123122

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

332331

333332-- 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.

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

335−subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do

336− let currentid = transactionId currentTrans

334+subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do

335+ let currentid = transactionId currentTrans'

337336 goalid = transactionId goalTrans

338− if currentTrans == goalTrans then

337+ if currentTrans' == goalTrans then

339338 Right (TransactionGraph resultHeads traverseSet) -- add filter

340339 --catch root transaction to improve error?

341340 else do

342− currentTransChildren <- childTransactions currentTrans origGraph

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

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

341+ currentTransChildren <- childTransactions currentTrans' origGraph

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

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

345344 childSearches = map searchChild (S.toList searchChildren)

346345 errors = lefts childSearches

347346 pathsFound = rights childSearches

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

350349 unless (null realErrors) (Left (head realErrors))

351350 -- if no paths found, search the parent

352351 if null pathsFound then

353− case oneParent currentTrans of

352+ case oneParent currentTrans' of

354353 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)

355354 Left err -> Left err

356355 Right currentTransParent ->

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

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

358357 else -- we found a path

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

360359 where

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

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

3535

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

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

38−unionMergeRelVars prefer relvarsA relvarsB = do

38+unionMergeRelVars _ relvarsA relvarsB = do

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

4040 foldM (\acc name -> do

4141 mergedRel <- do

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

4343 lookupA = findRel relvarsA

4444 lookupB = findRel relvarsB

4545 case (lookupA, lookupB) of

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

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

4747 --unionMergeRelation prefer relA relB

4848 (Nothing, Just relB) -> pure relB

4949 (Just relA, Nothing) -> pure relA

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

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

11module ProjectM36.TransactionGraph.Persist where

22import ProjectM36.Error

3−import ProjectM36.TransactionGraph

43import ProjectM36.Transaction

54import ProjectM36.Transaction.Persist

65import ProjectM36.RelationalExpression