1046167 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP compilation checkpoint

1046167AgentM7 years ago

src/lib/ProjectM36/Client.hs+6−3

compare with master

unifiedsplit

@@ -931,8 +931,9 @@ planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do

931 Right (session, _) ->

932 if schemaName session == defaultSchemaName then do

933 let ctx = Sess.concreteDatabaseContext session

934+ transId = Sess.parentId session

934 gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr dbExpr)

935 gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr dbExpr)

935− pure $ runGraphRefStaticOptimizerMonad (Just ctx) graph (optimizeGraphRefDatabaseContextExpr gfExpr)

936+ pure $ runGraphRefSOptDatabaseContextExprM transId ctx graph (optimizeGraphRefDatabaseContextExpr gfExpr)

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

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

937 pure (Left NonConcreteSchemaPlanError)

938 pure (Left NonConcreteSchemaPlanError)

938

939

@@ -968,11 +969,13 @@ relationVariablesAsRelation sessionId (InProcessConnection conf) = do

968 Right (session, schema) -> do

969 Right (session, schema) -> do

969 let context = Sess.concreteDatabaseContext session

970 let context = Sess.concreteDatabaseContext session

970 if Sess.schemaName session == defaultSchemaName then

971 if Sess.schemaName session == defaultSchemaName then

971− pure $ RE.relationVariablesAsRelation (relationVariables context) graph

972+ pure $ RE.relationVariablesAsRelation context graph

972 else

973 else

973 case Schema.relationVariablesInSchema schema of

974 case Schema.relationVariablesInSchema schema of

974 Left err -> pure (Left err)

975 Left err -> pure (Left err)

976+ Right relvars -> do

977+ let schemaContext = context {relationVariables = relvars }

975− Right relvars -> pure $ RE.relationVariablesAsRelation relvars graph

978+ pure $ RE.relationVariablesAsRelation schemaContext graph

976

979

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

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

978

981

src/lib/ProjectM36/RelationalExpression.hs+58−24

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

1{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleContexts #-}

2module ProjectM36.RelationalExpression where

4module ProjectM36.RelationalExpression where

3import ProjectM36.Relation

5import ProjectM36.Relation

4import ProjectM36.Tuple

6import ProjectM36.Tuple

@@ -33,7 +35,7 @@ import Control.Monad.Reader as R hiding (join)

33import ProjectM36.NormalizeExpr

35import ProjectM36.NormalizeExpr

34import ProjectM36.WithNameExpr

36import ProjectM36.WithNameExpr

35import Test.QuickCheck

37import Test.QuickCheck

36−import GHC

38+import GHC hiding (getContext)

37import GHC.Paths

39import GHC.Paths

38import Data.Time.Clock

40import Data.Time.Clock

39import Data.Time.Calendar

41import Data.Time.Calendar

@@ -362,6 +364,7 @@ setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()

362setRelVar relVarName relExpr = do

364setRelVar relVarName relExpr = do

363

365

364 currentContext <- getStateContext

366 currentContext <- getStateContext

367+ --prevent recursive relvar definition

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

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

366 potentialContext = currentContext { relationVariables = newRelVars }

369 potentialContext = currentContext { relationVariables = newRelVars }

367 --determine when to check constraints

370 --determine when to check constraints

@@ -433,37 +436,31 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

433 dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))

436 dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))

434

437

435evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

438evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

439+ gfExpr <- relVarByName relVarName

436 evalGraphRefDatabaseContextExpr (Assign relVarName

440 evalGraphRefDatabaseContextExpr (Assign relVarName

437 (Union

441 (Union

438− (RelationVariable relVarName UncommittedContextMarker)

442+ gfExpr

439 relExpr))

443 relExpr))

440

444

441evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

445evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

442− transId <- dbcTransId

446+ gfExpr <- relVarByName relVarName

443− let rv = RelationVariable relVarName (TransactionMarker transId)

444− setRelVar relVarName (Restrict (NotPredicate predicate) rv)

447+ setRelVar relVarName (Restrict (NotPredicate predicate) gfExpr)

445

448

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

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

447evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

450evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

448− context <- getStateContext

451+ rvExpr <- relVarByName relVarName

449− transId <- dbcTransId

450− let relVarMap = relationVariables context

451− case M.lookup relVarName relVarMap of

452− Nothing -> dbErr (RelVarNotDefinedError relVarName)

453− Just _ -> do

454− let unrestrictedPortion = Restrict (NotPredicate pred') rv

452+ let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr

455− rv = RelationVariable relVarName (TransactionMarker transId)

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

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

457− updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)

454+ updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)

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

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

459 --TODO restrictedPortion = Restrict pred'

456 --TODO restrictedPortion = Restrict pred'

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

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

461 let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in

458 let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in

462 updateAttr oldname procAtomExpr accum

459 updateAttr oldname procAtomExpr accum

463− ) rv (M.toList atomExprMap)

460+ ) rvExpr (M.toList atomExprMap)

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

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

465− updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)

462+ updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)

466− setRelVar relVarName (Union unrestrictedPortion updatedPortion)

463+ setRelVar relVarName (Union unrestrictedPortion updatedPortion)

467

464

468evalGraphRefDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do

465evalGraphRefDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do

469 currContext <- getStateContext

466 currContext <- getStateContext

@@ -539,6 +536,7 @@ evalGraphRefDatabaseContextExpr (RemoveTypeConstructor tConsName) = do

539

536

540evalGraphRefDatabaseContextExpr (MultipleExpr exprs) = do

537evalGraphRefDatabaseContextExpr (MultipleExpr exprs) = do

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

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

539+ ctx <- getContext

542 mapM_ (\expr -> evalGraphRefDatabaseContextExpr expr) exprs

540 mapM_ (\expr -> evalGraphRefDatabaseContextExpr expr) exprs

543

541

544evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do

542evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do

@@ -1417,13 +1415,14 @@ dbErr :: RelationalError -> DatabaseContextEvalMonad ()

1417dbErr err = lift (except (Left err))

1415dbErr err = lift (except (Left err))

1418

1416

1419-- | Return a Relation describing the relation variables.

1417-- | Return a Relation describing the relation variables.

1420−relationVariablesAsRelation :: RelationVariables -> TransactionGraph -> Either RelationalError Relation

1418+relationVariablesAsRelation :: DatabaseContext -> TransactionGraph -> Either RelationalError Relation

1421−relationVariablesAsRelation relVarMap graph = do

1419+relationVariablesAsRelation ctx graph = do

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

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

1423 attrs = A.attributesFromList [Attribute "name" TextAtomType,

1421 attrs = A.attributesFromList [Attribute "name" TextAtomType,

1424 Attribute "attributes" (RelationAtomType subrelAttrs)]

1422 Attribute "attributes" (RelationAtomType subrelAttrs)]

1423+ relVars = relationVariables ctx

1425 mkRvDesc (rvName, gfExpr) = do

1424 mkRvDesc (rvName, gfExpr) = do

1426− let gfEnv = freshGraphRefRelationalExprEnv Nothing graph

1425+ let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph

1427 gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

1426 gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

1428 pure (rvName, gfType)

1427 pure (rvName, gfType)

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

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

@@ -1431,8 +1430,43 @@ relationVariablesAsRelation relVarMap graph = do

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

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

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

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

1433 Right rel -> RelationAtom rel

1432 Right rel -> RelationAtom rel

1434− rvs <- mapM mkRvDesc (M.toList relVarMap)

1433+ rvs <- mapM mkRvDesc (M.toList relVars)

1435 let tups = map relVarToAtomList rvs

1434 let tups = map relVarToAtomList rvs

1436 mkRelationFromList attrs tups

1435 mkRelationFromList attrs tups

1437

1436

1437+-- | An unoptimized variant of evalGraphRefRelationalExpr for testing.

1438+evalRelationalExpr :: RelationalExpr -> RelationalExprM Relation

1439+evalRelationalExpr expr = do

1440+ graph <- reGraph

1441+ context <- reContext

1442+ let expr' = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)

1443+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

1444+ case runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr expr') of

1445+ Left err -> throwError err

1446+ Right rel -> pure rel

1447+

1448+{-

1449+relVarByName :: RelVarName -> GraphRefRelationalExprM GraphRefRelationalExpr

1450+relVarByName = do

1451+ relvars <- relationVariables <$> getStateContext

1452+ case M.lookup relVarName relvars of

1453+ Nothing -> dbErr (RelVarNotDefinedError relVarName)

1454+ Just gfexpr -> pure gfExpr

1455+-}

1456+

1457+class (MonadError RelationalError m, Monad m) => DatabaseContextM m where

1458+ getContext :: m DatabaseContext

1459+

1460+instance DatabaseContextM (ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity)) where

1461+ getContext = gfDatabaseContextForMarker UncommittedContextMarker

1462+

1463+instance DatabaseContextM (RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity)) where

1464+ getContext = getStateContext

1465+

1466+relVarByName :: DatabaseContextM m => RelVarName -> m GraphRefRelationalExpr

1467+relVarByName rvName = do

1468+ relvars <- relationVariables <$> getContext

1469+ case M.lookup rvName relvars of

1470+ Nothing -> throwError (RelVarNotDefinedError rvName)

1471+ Just gfexpr -> pure gfexpr

1438

1472

src/lib/ProjectM36/StaticOptimizer.hs+136−42

@@ -1,3 +1,6 @@

1+{-# LANGUAGE TypeSynonymInstances #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleContexts #-}

1module ProjectM36.StaticOptimizer where

4module ProjectM36.StaticOptimizer where

2import ProjectM36.Base

5import ProjectM36.Base

3import ProjectM36.GraphRefRelationalExpr

6import ProjectM36.GraphRefRelationalExpr

@@ -18,12 +21,26 @@ import Data.Functor.Identity

18import qualified Data.Map as M

21import qualified Data.Map as M

19import qualified Data.Set as S

22import qualified Data.Set as S

21−type StaticOptimizerEnv = RelationalExprEnv

22−

23−type StaticOptimizerMonad a = ReaderT StaticOptimizerEnv (ExceptT RelationalError Identity) a

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

26−type GraphRefStaticOptimizerMonad a = ReaderT (Maybe DatabaseContext, TransactionGraph) (ExceptT RelationalError Identity) a

26+data GraphRefSOptRelationalExprEnv =

27+ GraphRefSOptRelationalExprEnv

28+ {

29+ ore_graph :: TransactionGraph,

30+ ore_mcontext :: Maybe DatabaseContext

31+ }

32+

33+type GraphRefSOptRelationalExprM a = ReaderT GraphRefSOptRelationalExprEnv (ExceptT RelationalError Identity) a

34+

35+data GraphRefSOptDatabaseContextExprEnv =

36+ GraphRefSOptDatabaseContextExprEnv

37+ {

38+ odce_graph :: TransactionGraph,

39+ odce_context :: DatabaseContext, --not optional for DatabaseContextExpr evaluation

40+ odce_transId :: TransactionId -- parent if context is committed- needed because MultipleExpr optimization requires running the DatabaseContextExprs (with empty relvars)

41+ }

42+

43+type GraphRefSOptDatabaseContextExprM a = ReaderT GraphRefSOptDatabaseContextExprEnv (ExceptT RelationalError Identity) a

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

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

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

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

@@ -32,28 +49,44 @@ optimizeAndEvalRelationalExpr env expr = do

32 graph = re_graph env

49 graph = re_graph env

33 ctx = re_context env

50 ctx = re_context env

34 gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph

51 gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph

35− optExpr <- runGraphRefStaticOptimizerMonad (Just ctx) (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr)

52+ optExpr <- runGraphRefSOptRelationalExprM (Just ctx) (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr)

36 runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

53 runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

55+class Monad m => AskGraphContext m where

38−askGraph :: GraphRefStaticOptimizerMonad TransactionGraph

56+ askGraph :: m TransactionGraph

57+ askContext :: m DatabaseContext

58+

59+instance AskGraphContext (ReaderT GraphRefSOptDatabaseContextExprEnv (ExceptT RelationalError Identity)) where

39−askGraph = snd <$> ask

60+ askGraph = odce_graph <$> ask

61+ askContext = odce_context <$> ask

41−askContext :: GraphRefStaticOptimizerMonad DatabaseContext

63+instance AskGraphContext (ReaderT GraphRefSOptRelationalExprEnv (ExceptT RelationalError Identity)) where

64+ askGraph = ore_graph <$> ask

42−askContext = do

65+ askContext = do

43− mctx <- fst <$> ask

66+ mctx <- ore_mcontext <$> ask

44− case mctx of

67+ case mctx of

45− Nothing -> throwError NoUncommittedContextInEvalError

68+ Nothing -> throwError NoUncommittedContextInEvalError

46− Just ctx -> pure ctx

69+ Just ctx -> pure ctx

48−askMaybeContext :: GraphRefStaticOptimizerMonad (Maybe DatabaseContext)

71+askTransId :: GraphRefSOptDatabaseContextExprM TransactionId

49−askMaybeContext = fst <$> ask

72+askTransId = odce_transId <$> ask

74+askMaybeContext :: GraphRefSOptRelationalExprM (Maybe DatabaseContext)

75+askMaybeContext = ore_mcontext <$> ask

76+

77+optimizeDatabaseContextExpr :: DatabaseContextExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextExpr

78+optimizeDatabaseContextExpr expr = do

79+ let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr expr)

80+ optimizeGraphRefDatabaseContextExpr gfExpr

81+

51optimizeAndEvalDatabaseContextExpr :: Bool -> DatabaseContextExpr -> DatabaseContextEvalMonad ()

82optimizeAndEvalDatabaseContextExpr :: Bool -> DatabaseContextExpr -> DatabaseContextEvalMonad ()

52optimizeAndEvalDatabaseContextExpr optimize expr = do

83optimizeAndEvalDatabaseContextExpr optimize expr = do

53 graph <- dce_graph <$> ask

84 graph <- dce_graph <$> ask

85+ transId <- dce_transId <$> ask

86+ context <- getStateContext

54 let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr expr)

87 let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr expr)

55 eOptExpr = if optimize then

88 eOptExpr = if optimize then

56− runGraphRefStaticOptimizerMonad Nothing graph (optimizeGraphRefDatabaseContextExpr gfExpr)

89+ runGraphRefSOptDatabaseContextExprM transId context graph (optimizeGraphRefDatabaseContextExpr gfExpr)

57 else

90 else

58 pure gfExpr

91 pure gfExpr

59 case eOptExpr of

92 case eOptExpr of

@@ -64,31 +97,76 @@ optimizeAndEvalDatabaseContextExpr optimize expr = do

64optimizeAndEvalTransGraphRelationalExpr :: TransactionGraph -> TransGraphRelationalExpr -> Either RelationalError Relation

97optimizeAndEvalTransGraphRelationalExpr :: TransactionGraph -> TransGraphRelationalExpr -> Either RelationalError Relation

65optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do

98optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do

66 gfExpr <- TGRE.process (TransGraphEvalEnv graph) tgExpr

99 gfExpr <- TGRE.process (TransGraphEvalEnv graph) tgExpr

67− optExpr <- runGraphRefStaticOptimizerMonad Nothing graph (fullOptimizeGraphRefRelationalExpr gfExpr)

100+ optExpr <- runGraphRefSOptRelationalExprM Nothing graph (fullOptimizeGraphRefRelationalExpr gfExpr)

68 let gfEnv = freshGraphRefRelationalExprEnv Nothing graph

101 let gfEnv = freshGraphRefRelationalExprEnv Nothing graph

69 runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

102 runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

103

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

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

72optimizeAndEvalDatabaseContextIOExpr expr = do

105optimizeAndEvalDatabaseContextIOExpr expr = do

73− env <- getDBCIORelationalExprEnv

106+ transId <- dbcio_transId <$> ask

107+ ctx <- getDBCIOContext

108+ graph <- dbcio_graph <$> ask

74 let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextIOExpr expr)

109 let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextIOExpr expr)

75− eOptExpr = runStaticOptimizerMonad env (optimizeDatabaseContextIOExpr gfExpr)

110+ eOptExpr = runGraphRefSOptDatabaseContextExprM transId ctx graph (optimizeDatabaseContextIOExpr gfExpr)

76 case eOptExpr of

111 case eOptExpr of

77 Left err -> pure (Left err)

112 Left err -> pure (Left err)

78 Right optExpr ->

113 Right optExpr ->

79 evalGraphRefDatabaseContextIOExpr optExpr

114 evalGraphRefDatabaseContextIOExpr optExpr

115

81−

116+{-

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

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

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

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

119+-}

120+

121+runGraphRefSOptRelationalExprM ::

122+ Maybe DatabaseContext ->

123+ TransactionGraph ->

124+ GraphRefSOptRelationalExprM a ->

125+ Either RelationalError a

126+runGraphRefSOptRelationalExprM mctx graph m = runIdentity (runExceptT (runReaderT m env))

127+ where

128+ env = GraphRefSOptRelationalExprEnv {

129+ ore_graph = graph,

130+ ore_mcontext = mctx

131+ }

132+

133

85−runGraphRefStaticOptimizerMonad :: Maybe DatabaseContext -> TransactionGraph -> GraphRefStaticOptimizerMonad a -> Either RelationalError a

134+runGraphRefSOptDatabaseContextExprM ::

135+ TransactionId ->

136+ DatabaseContext ->

137+ TransactionGraph ->

138+ GraphRefSOptDatabaseContextExprM a ->

139+ Either RelationalError a

140+runGraphRefSOptDatabaseContextExprM tid ctx graph m =

86−runGraphRefStaticOptimizerMonad ctx graph m = runIdentity (runExceptT (runReaderT m (ctx, graph)))

141+ runIdentity (runExceptT (runReaderT m env))

87−

142+ where

143+ env = GraphRefSOptDatabaseContextExprEnv {

144+ odce_graph = graph,

145+ odce_context = ctx,

146+ odce_transId = tid

147+ }

148+

149+optimizeGraphRefRelationalExpr' ::

150+ Maybe DatabaseContext ->

151+ TransactionGraph ->

152+ GraphRefRelationalExpr ->

88−optimizeGraphRefRelationalExpr' :: Maybe DatabaseContext -> TransactionGraph -> GraphRefRelationalExpr -> Either RelationalError GraphRefRelationalExpr

153+ Either RelationalError GraphRefRelationalExpr

154+optimizeGraphRefRelationalExpr' mctx graph expr =

89−optimizeGraphRefRelationalExpr' mctx graph expr = runIdentity (runExceptT (runReaderT (optimizeGraphRefRelationalExpr expr) (mctx,graph)))

155+ runIdentity (runExceptT (runReaderT (optimizeGraphRefRelationalExpr expr) env))

90−

156+ where

157+ env = GraphRefSOptRelationalExprEnv {

158+ ore_graph = graph,

159+ ore_mcontext = mctx

160+ }

161+

162+-- | optimize relational expression within database context expr monad

163+liftGraphRefRelExpr :: GraphRefSOptRelationalExprM a -> GraphRefSOptDatabaseContextExprM a

164+liftGraphRefRelExpr m = do

165+ context <- odce_context <$> ask

166+ graph <- odce_graph <$> ask

167+ lift $ except $ runGraphRefSOptRelationalExprM (Just context) graph m

168+

91−fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

169+fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

92fullOptimizeGraphRefRelationalExpr expr = do

170fullOptimizeGraphRefRelationalExpr expr = do

93 optExpr <- optimizeGraphRefRelationalExpr expr

171 optExpr <- optimizeGraphRefRelationalExpr expr

94 let optExpr' = applyStaticRestrictionPushdown (applyStaticRestrictionCollapse optExpr)

172 let optExpr' = applyStaticRestrictionPushdown (applyStaticRestrictionCollapse optExpr)

@@ -97,7 +175,7 @@ fullOptimizeGraphRefRelationalExpr expr = do

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

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

176

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

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

100−optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

178+optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

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

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

102

180

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

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

@@ -109,8 +187,9 @@ optimizeGraphRefRelationalExpr e@(RelationVariable _ _) = pure e

109--remove project of attributes which removes no attributes

187--remove project of attributes which removes no attributes

110optimizeGraphRefRelationalExpr (Project attrNameSet expr) = do

188optimizeGraphRefRelationalExpr (Project attrNameSet expr) = do

111 graph <- askGraph

189 graph <- askGraph

190+ mctx <- askMaybeContext

112 let relType = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)

191 let relType = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)

113− gfEnv = freshGraphRefRelationalExprEnv Nothing graph

192+ gfEnv = freshGraphRefRelationalExprEnv mctx graph

114 case relType of

193 case relType of

115 Left err -> throwError err

194 Left err -> throwError err

116 Right relType2

195 Right relType2

@@ -171,12 +250,13 @@ optimizeGraphRefRelationalExpr (Ungroup attrName expr) =

171--remove restriction of nothing

250--remove restriction of nothing

172optimizeGraphRefRelationalExpr (Restrict predicate expr) = do

251optimizeGraphRefRelationalExpr (Restrict predicate expr) = do

173 graph <- askGraph

252 graph <- askGraph

253+ mctx <- askMaybeContext

174 optimizedPredicate <- applyStaticPredicateOptimization predicate

254 optimizedPredicate <- applyStaticPredicateOptimization predicate

175 case optimizedPredicate of

255 case optimizedPredicate of

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

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

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

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

178 let attributesRel = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)

258 let attributesRel = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)

179− gfEnv = freshGraphRefRelationalExprEnv Nothing graph

259+ gfEnv = freshGraphRefRelationalExprEnv mctx graph

180 case attributesRel of

260 case attributesRel of

181 Left err -> throwError err

261 Left err -> throwError err

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

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

@@ -193,18 +273,18 @@ optimizeGraphRefRelationalExpr e@(Extend _ _) = pure e

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

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

194

274

195-- database context expr

275-- database context expr

196−optimizeGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> GraphRefStaticOptimizerMonad GraphRefDatabaseContextExpr

276+optimizeGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextExpr

197optimizeGraphRefDatabaseContextExpr x@NoOperation = pure x

277optimizeGraphRefDatabaseContextExpr x@NoOperation = pure x

198optimizeGraphRefDatabaseContextExpr x@(Define _ _) = pure x

278optimizeGraphRefDatabaseContextExpr x@(Define _ _) = pure x

199

279

200optimizeGraphRefDatabaseContextExpr x@(Undefine _) = pure x

280optimizeGraphRefDatabaseContextExpr x@(Undefine _) = pure x

201

281

202optimizeGraphRefDatabaseContextExpr (Assign name expr) = do

282optimizeGraphRefDatabaseContextExpr (Assign name expr) = do

203− optExpr <- optimizeGraphRefRelationalExpr expr

283+ optExpr <- liftGraphRefRelExpr (fullOptimizeGraphRefRelationalExpr expr)

204 pure $ Assign name optExpr

284 pure $ Assign name optExpr

205

285

206optimizeGraphRefDatabaseContextExpr (Insert targetName expr) = do

286optimizeGraphRefDatabaseContextExpr (Insert targetName expr) = do

207− optimizedExpr <- fullOptimizeGraphRefRelationalExpr expr

287+ optimizedExpr <- liftGraphRefRelExpr (fullOptimizeGraphRefRelationalExpr expr)

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

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

209 pure NoOperation

289 pure NoOperation

210 else

290 else

@@ -215,10 +295,10 @@ optimizeGraphRefDatabaseContextExpr (Insert targetName expr) = do

215 _ -> pure (Insert targetName optimizedExpr)

295 _ -> pure (Insert targetName optimizedExpr)

216

296

217optimizeGraphRefDatabaseContextExpr (Delete name predicate) =

297optimizeGraphRefDatabaseContextExpr (Delete name predicate) =

218− Delete name <$> applyStaticPredicateOptimization predicate

298+ Delete name <$> liftGraphRefRelExpr (applyStaticPredicateOptimization predicate)

219

299

220optimizeGraphRefDatabaseContextExpr (Update name upmap predicate) =

300optimizeGraphRefDatabaseContextExpr (Update name upmap predicate) =

221− Update name upmap <$> applyStaticPredicateOptimization predicate

301+ Update name upmap <$> liftGraphRefRelExpr (applyStaticPredicateOptimization predicate)

222

302

223optimizeGraphRefDatabaseContextExpr dep@(AddInclusionDependency _ _) = pure dep

303optimizeGraphRefDatabaseContextExpr dep@(AddInclusionDependency _ _) = pure dep

224

304

@@ -240,14 +320,28 @@ optimizeGraphRefDatabaseContextExpr c@(ExecuteDatabaseContextFunction _ _) = pur

240

320

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

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

242--for multiple expressions, we must evaluate

322--for multiple expressions, we must evaluate

243−optimizeGraphRefDatabaseContextExpr x@(MultipleExpr _) = pure x

323+optimizeGraphRefDatabaseContextExpr (MultipleExpr exprs) = do

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

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

245−-- unimplemented

325+ context <- askContext

326+ graph <- askGraph

327+ parentId <- askTransId

328+

246−{- let processEmptyRelVars env = env { relationVariables = mkEmptyRelVars (relationVariables env) }

329+ let emptyRvs ctx = ctx { relationVariables = mkEmptyRelVars (relationVariables ctx) }

247− MultipleExpr <$> local processEmptyRelVars (mapM applyStaticDatabaseOptimization exprs)-}

330+ dbcEnv = mkDatabaseContextEvalEnv parentId graph

331+ folder (ctx, expracc) expr = do

332+ --optimize the expr and run it against empty relvars to add it to the context

333+ case runGraphRefSOptDatabaseContextExprM parentId ctx graph (optimizeGraphRefDatabaseContextExpr expr) of

334+ Left err -> throwError err

335+ Right optExpr ->

336+ case runDatabaseContextEvalMonad ctx dbcEnv (evalGraphRefDatabaseContextExpr optExpr) of

337+ Left err -> throwError err

338+ Right dbcState ->

339+ pure (emptyRvs $ dbc_context dbcState, expracc ++ [optExpr])

248

340

341+ (_, exprs') <- foldM folder (context,[]) exprs

342+ pure (MultipleExpr exprs')

249

343

250−applyStaticPredicateOptimization :: GraphRefRestrictionPredicateExpr -> GraphRefStaticOptimizerMonad GraphRefRestrictionPredicateExpr

344+applyStaticPredicateOptimization :: GraphRefRestrictionPredicateExpr -> GraphRefSOptRelationalExprM GraphRefRestrictionPredicateExpr

251applyStaticPredicateOptimization predi = do

345applyStaticPredicateOptimization predi = do

252 optPred <- case predi of

346 optPred <- case predi of

253-- where x and x => where x

347-- where x and x => where x

@@ -340,7 +434,7 @@ isStaticAtomExpr FunctionAtomExpr{} = False

340isStaticAtomExpr RelationAtomExpr{} = False

434isStaticAtomExpr RelationAtomExpr{} = False

341

435

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

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

343−applyStaticJoinElimination :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

437+applyStaticJoinElimination :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

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

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

345 graph <- askGraph

439 graph <- askGraph

346 case inSameTransaction exprA exprB of

440 case inSameTransaction exprA exprB of

@@ -480,5 +574,5 @@ applyStaticRestrictionPushdown expr = case expr of

480 Extend n (applyStaticRestrictionPushdown sub)

574 Extend n (applyStaticRestrictionPushdown sub)

481

575

482-- no optimizations available

576-- no optimizations available

483−optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> StaticOptimizerMonad GraphRefDatabaseContextIOExpr

577+optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr

484optimizeDatabaseContextIOExpr x = pure x

578optimizeDatabaseContextIOExpr x = pure x

src/lib/ProjectM36/TransactionGraph.hs+12−6

@@ -25,16 +25,11 @@ import Data.Binary

25import Data.Either (lefts, rights, isRight)

26import Control.Arrow

27import Data.Maybe

28+import Data.UUID.V4

28#if __GLASGOW_HASKELL__ <= 802

29#if __GLASGOW_HASKELL__ <= 802

29import Data.Monoid

30import Data.Monoid

30#endif

31#endif

32−{-

33−--import Debug.Trace

34−import Control.Monad.Reader

35−import qualified ProjectM36.DisconnectedTransaction as D

36−-}

37−

38-- | Record a lookup for a specific transaction in the graph.

33-- | Record a lookup for a specific transaction in the graph.

39data TransactionIdLookup = TransactionIdLookup TransactionId |

34data TransactionIdLookup = TransactionIdLookup TransactionId |

40 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]

35 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]

@@ -73,6 +68,14 @@ bootstrapTransactionGraph stamp' freshId context = TransactionGraph bootstrapHea

73 freshTransaction = fresh freshId stamp' newSchemas

68 freshTransaction = fresh freshId stamp' newSchemas

74 bootstrapTransactions = S.singleton freshTransaction

69 bootstrapTransactions = S.singleton freshTransaction

71+-- | Create a transaction graph from a context.

72+freshTransactionGraph :: DatabaseContext -> IO (TransactionGraph, TransactionId)

73+freshTransactionGraph ctx = do

74+ now <- getCurrentTime

75+ freshId <- nextRandom

76+ pure $ (bootstrapTransactionGraph now freshId ctx, freshId)

77+

78+

76emptyTransactionGraph :: TransactionGraph

79emptyTransactionGraph :: TransactionGraph

77emptyTransactionGraph = TransactionGraph M.empty S.empty

80emptyTransactionGraph = TransactionGraph M.empty S.empty

@@ -98,6 +101,9 @@ transactionsForIds idSet graph =

98isRootTransaction :: Transaction -> Bool

101isRootTransaction :: Transaction -> Bool

99isRootTransaction trans = parentIds trans == S.singleton U.nil

102isRootTransaction trans = parentIds trans == S.singleton U.nil

100

103

104+rootTransactions :: TransactionGraph -> S.Set Transaction

105+rootTransactions graph = S.filter isRootTransaction (transactionsForGraph graph)

106+

101-- the first transaction has no parent - all other do have parents- merges have two parents

107-- the first transaction has no parent - all other do have parents- merges have two parents

102parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

108parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

103parentTransactions trans graph = transactionsForIds (parentIds trans) graph

109parentTransactions trans graph = transactionsForIds (parentIds trans) graph

test/IsomorphicSchema.hs+40−28

@@ -4,16 +4,16 @@ import ProjectM36.Error

4import ProjectM36.IsomorphicSchema

5import ProjectM36.Relation

6import ProjectM36.RelationalExpression

7+import ProjectM36.TransactionGraph

8+import ProjectM36.StaticOptimizer

7import qualified ProjectM36.DatabaseContext as DBC

9import qualified ProjectM36.DatabaseContext as DBC

8import qualified ProjectM36.Attribute as A

10import qualified ProjectM36.Attribute as A

9import System.Exit

11import System.Exit

10import qualified Data.Map as M

12import qualified Data.Map as M

11import qualified Data.Set as S

13import qualified Data.Set as S

12−import Control.Monad.State

13−import Control.Monad.Trans.Reader

15testList :: Test

16−testList = TestList [testIsoRename, testIsoRestrict, testIsoUnion, testSchemaValidation]

16+testList = TestList [testIsoRename, testIsoRestrict]--, testIsoUnion, testSchemaValidation]

18main :: IO ()

19main = do

@@ -36,7 +36,7 @@ assertMaybe x msg = case x of

36testSchemaValidation :: Test

37testSchemaValidation = TestCase $ do

38 let potentialSchema = DBC.basicDatabaseContext {

39− relationVariables = M.singleton "anotherRel" relationTrue

39+ relationVariables = M.singleton "anotherRel" (ExistingRelation relationTrue)

40 }

41 -- missing relvars failure

42 morphs = [IsoRename "true" "true", IsoRename "false" "false"]

@@ -50,15 +50,17 @@ testSchemaValidation = TestCase $ do

50testIsoRename :: Test

51testIsoRename = TestCase $ do

52 -- create a schema with two relvars and rename one while the other remains the same in the isomorphic schema

53− let schemaA = mkRelationalExprState DBC.empty {

53+ let ctx = DBC.empty {

54− relationVariables = M.fromList [("employee", relationTrue),

54+ relationVariables = M.fromList [("employee", ExistingRelation relationTrue),

55− ("department", relationFalse)]

55+ ("department", ExistingRelation relationFalse)]

56 }

57+ (graph, _) <- freshTransactionGraph ctx

57− isomorphsAtoB = [IsoRename "emp" "employee",

58+ let isomorphsAtoB = [IsoRename "emp" "employee",

58 IsoRename "department" "department"]

59 IsoRename "department" "department"]

59− unionExpr = Union (RelationVariable "emp" ()) (RelationVariable "department" ())

60+ unionExpr = Union (RelationVariable "emp" ()) (RelationVariable "department" ())

61+ env = mkRelationalExprEnv ctx graph

60 relExpr <- assertEither (applyRelationalExprSchemaIsomorphs isomorphsAtoB unionExpr)

62 relExpr <- assertEither (applyRelationalExprSchemaIsomorphs isomorphsAtoB unionExpr)

61− let relResult = runReader (evalRelationalExpr relExpr) schemaA

63+ let relResult = optimizeAndEvalRelationalExpr env relExpr

62 assertEqual "employee relation morph" (Right relationTrue) relResult

64 assertEqual "employee relation morph" (Right relationTrue) relResult

64testIsoRestrict :: Test

66testIsoRestrict :: Test

@@ -67,62 +69,72 @@ testIsoRestrict = TestCase $ do

67 -- the virtual schema has an employee

69 -- the virtual schema has an employee

68 let empattrs = A.attributesFromList [Attribute "name" TextAtomType,

70 let empattrs = A.attributesFromList [Attribute "name" TextAtomType,

69 Attribute "boss" TextAtomType]

71 Attribute "boss" TextAtomType]

72+ (graph, transId) <- freshTransactionGraph DBC.empty

70 emprel <- assertEither $ mkRelationFromList empattrs

73 emprel <- assertEither $ mkRelationFromList empattrs

71 [[TextAtom "Steve", TextAtom ""],

74 [[TextAtom "Steve", TextAtom ""],

72 [TextAtom "Cindy", TextAtom "Steve"],

75 [TextAtom "Cindy", TextAtom "Steve"],

73 [TextAtom "Sam", TextAtom "Steve"]]

76 [TextAtom "Sam", TextAtom "Steve"]]

74 let predicate = AttributeEqualityPredicate "boss" (NakedAtomExpr (TextAtom ""))

77 let predicate = AttributeEqualityPredicate "boss" (NakedAtomExpr (TextAtom ""))

78+ reenv = mkRelationalExprEnv DBC.empty graph

75− bossRel <- assertEither $ runReader (evalRelationalExpr (Restrict predicate (ExistingRelation emprel))) (mkRelationalExprState DBC.empty)

79+ bossRel <- assertEither $ runRelationalExprM reenv (evalRelationalExpr (Restrict predicate (ExistingRelation emprel)))

80+ print "spam1"

76− nonBossRel <- assertEither $ runReader (evalRelationalExpr (Restrict (NotPredicate predicate) (ExistingRelation emprel))) (mkRelationalExprState DBC.empty)

81+ nonBossRel <- assertEither $ runRelationalExprM reenv (evalRelationalExpr (Restrict (NotPredicate predicate) (ExistingRelation emprel)))

78− let schemaA = mkRelationalExprState DBC.empty {

83+ let schemaA = mkRelationalExprEnv baseContext graph

84+ baseContext = DBC.empty {

79− relationVariables = M.fromList [("nonboss", nonBossRel),

85+ relationVariables = M.fromList [("nonboss", ExistingRelation nonBossRel),

80− ("boss", bossRel)]

86+ ("boss", ExistingRelation bossRel)]

81 }

87 }

82−

83 isomorphsAtoB = [IsoRestrict "employee" predicate ("boss", "nonboss")]

88 isomorphsAtoB = [IsoRestrict "employee" predicate ("boss", "nonboss")]

84 bossq = RelationVariable "boss" ()

89 bossq = RelationVariable "boss" ()

85 nonbossq = RelationVariable "nonboss" ()

90 nonbossq = RelationVariable "nonboss" ()

86 employeeq = RelationVariable "employee" ()

91 employeeq = RelationVariable "employee" ()

87 unionq = Union bossq nonbossq

92 unionq = Union bossq nonbossq

88 empExpr <- assertEither (applyRelationalExprSchemaIsomorphs isomorphsAtoB employeeq)

93 empExpr <- assertEither (applyRelationalExprSchemaIsomorphs isomorphsAtoB employeeq)

89− let empResult = runReader (evalRelationalExpr empExpr) schemaA

94+ let empResult = evalRelExpr (evalRelationalExpr empExpr)

90− unionResult = runReader (evalRelationalExpr unionq) schemaA

95+ unionResult = evalRelExpr (evalRelationalExpr unionq)

96+ evalRelExpr = runRelationalExprM schemaA

97+ print "spam2"

91 assertEqual "boss/nonboss isorestrict" unionResult empResult

98 assertEqual "boss/nonboss isorestrict" unionResult empResult

92 --execute database context expr

99 --execute database context expr

93 bobRel <- assertEither (mkRelationFromList empattrs [[TextAtom "Bob", TextAtom ""]])

100 bobRel <- assertEither (mkRelationFromList empattrs [[TextAtom "Bob", TextAtom ""]])

94 let schemaBInsertExpr = Insert "employee" (ExistingRelation bobRel)

101 let schemaBInsertExpr = Insert "employee" (ExistingRelation bobRel)

95 schemaBInsertExpr' <- assertEither (processDatabaseContextExprInSchema (Schema isomorphsAtoB) schemaBInsertExpr)

102 schemaBInsertExpr' <- assertEither (processDatabaseContextExprInSchema (Schema isomorphsAtoB) schemaBInsertExpr)

96− let (postInsertContext,_,_) = execState (evalDatabaseContextExpr schemaBInsertExpr') (freshDatabaseState (stateElemsContext schemaA))

103+ let Right dbcState = evalDBCExpr schemaBInsertExpr'

104+ postInsertContext = dbc_context dbcState

105+ evalDBCExpr expr' = runDatabaseContextEvalMonad baseContext dbcenv (optimizeAndEvalDatabaseContextExpr False expr')

106+ dbcenv = mkDatabaseContextEvalEnv transId graph

97− expectedRel = runReader (evalRelationalExpr (Union (RelationVariable "boss" ()) (RelationVariable "nonboss" ()))) (mkRelationalExprState postInsertContext)

107+ expectedRel = runRelationalExprM postInsertEnv (evalRelationalExpr (Union (RelationVariable "boss" ()) (RelationVariable "nonboss" ())))

108+ postInsertEnv = mkRelationalExprEnv postInsertContext graph

98 --execute the expression against the schema and compare against the base context

109 --execute the expression against the schema and compare against the base context

99 processedExpr <- assertEither (processRelationalExprInSchema (Schema isomorphsAtoB) (RelationVariable "employee" ()))

110 processedExpr <- assertEither (processRelationalExprInSchema (Schema isomorphsAtoB) (RelationVariable "employee" ()))

100− let processedRel = runReader (evalRelationalExpr processedExpr) (mkRelationalExprState postInsertContext)

111+ let processedRel = runRelationalExprM postInsertEnv (evalRelationalExpr processedExpr)

101 assertEqual "insert bob boss" expectedRel processedRel

112 assertEqual "insert bob boss" expectedRel processedRel

102

113

103testIsoUnion :: Test

114testIsoUnion :: Test

104testIsoUnion = TestCase $ do

115testIsoUnion = TestCase $ do

105 --create motors relation which is split into low-power (<50 horsepower) and high-power (>=50 horsepower) motors

116 --create motors relation which is split into low-power (<50 horsepower) and high-power (>=50 horsepower) motors

106 --the schema is contains the split relvars

117 --the schema is contains the split relvars

118+ (graph, _) <- freshTransactionGraph DBC.empty

107 motorsRel <- assertEither $ mkRelationFromList (A.attributesFromList [Attribute "name" TextAtomType,

119 motorsRel <- assertEither $ mkRelationFromList (A.attributesFromList [Attribute "name" TextAtomType,

108 Attribute "power" IntegerAtomType])

120 Attribute "power" IntegerAtomType])

109 [[TextAtom "Puny", IntegerAtom 10],

121 [[TextAtom "Puny", IntegerAtom 10],

110 [TextAtom "Scooter", IntegerAtom 49],

122 [TextAtom "Scooter", IntegerAtom 49],

111 [TextAtom "Auto", IntegerAtom 200],

123 [TextAtom "Auto", IntegerAtom 200],

112 [TextAtom "Tractor", IntegerAtom 500]]

124 [TextAtom "Tractor", IntegerAtom 500]]

113− let baseSchema = mkRelationalExprState DBC.basicDatabaseContext {

125+ let env = mkRelationalExprEnv DBC.basicDatabaseContext {

114− relationVariables = M.singleton "motor" motorsRel

126+ relationVariables = M.singleton "motor" (ExistingRelation motorsRel)

115− }

127+ } graph

116 splitPredicate = AtomExprPredicate (FunctionAtomExpr "lt" [AttributeAtomExpr "power", NakedAtomExpr (IntegerAtom 50)] ())

128 splitPredicate = AtomExprPredicate (FunctionAtomExpr "lt" [AttributeAtomExpr "power", NakedAtomExpr (IntegerAtom 50)] ())

117 splitIsomorphs = [IsoUnion ("lowpower", "highpower") splitPredicate "motor",

129 splitIsomorphs = [IsoUnion ("lowpower", "highpower") splitPredicate "motor",

118 IsoRename "true" "true",

130 IsoRename "true" "true",

119 IsoRename "false" "false"]

131 IsoRename "false" "false"]

120− lowmotors = runReader (evalRelationalExpr (Restrict splitPredicate (RelationVariable "motor" ()))) baseSchema

132+ lowmotors = runRelationalExprM env (evalRelationalExpr (Restrict splitPredicate (RelationVariable "motor" ())))

121− highmotors = runReader (evalRelationalExpr (Restrict (NotPredicate splitPredicate) (RelationVariable "motor" ()))) baseSchema

133+ highmotors = runRelationalExprM env (evalRelationalExpr (Restrict (NotPredicate splitPredicate) (RelationVariable "motor" ())))

122− relResult expr = runReader (evalRelationalExpr expr) baseSchema

134+ relResult expr = runRelationalExprM env (evalRelationalExpr expr)

123 lowpowerExpr <- assertEither (processRelationalExprInSchema (Schema splitIsomorphs) (RelationVariable "lowpower" ()))

135 lowpowerExpr <- assertEither (processRelationalExprInSchema (Schema splitIsomorphs) (RelationVariable "lowpower" ()))

124 lowpowerRel <- assertEither (relResult lowpowerExpr)

136 lowpowerRel <- assertEither (relResult lowpowerExpr)

125 highpowerExpr <- assertEither (processRelationalExprInSchema (Schema splitIsomorphs) (RelationVariable "highpower" ()))

137 highpowerExpr <- assertEither (processRelationalExprInSchema (Schema splitIsomorphs) (RelationVariable "highpower" ()))

126 highpowerRel <- assertEither (relResult highpowerExpr)

138 highpowerRel <- assertEither (relResult highpowerExpr)

127 assertEqual "lowpower relation difference" (Right lowpowerRel) lowmotors

139 assertEqual "lowpower relation difference" (Right lowpowerRel) lowmotors

128− assertEqual "highpower relation difference" (Right highpowerRel) highmotors

140+ assertEqual "highpower relation difference" (Right highpowerRel) highmotors

test/Relation/Basic.hs+10−4

@@ -7,9 +7,9 @@ import ProjectM36.TupleSet

7import ProjectM36.Attribute hiding (null, attributeNames)

8import ProjectM36.DataTypes.Primitive

9import ProjectM36.RelationalExpression

10+import ProjectM36.TransactionGraph

10import ProjectM36.Tuple

11import ProjectM36.Tuple

11import qualified ProjectM36.DatabaseContext as DBC

12import qualified ProjectM36.DatabaseContext as DBC

12−import Control.Monad.Trans.Reader

13import qualified ProjectM36.Attribute as A

14import qualified Data.Map as M

15import qualified Data.Vector as V

@@ -94,8 +94,12 @@ testMkRelation1 = TestCase $ assertEqual "key mismatch" expectedError (mkRelatio

95testMkRelationFromExprsBadAttrs :: Test

96testMkRelationFromExprsBadAttrs = TestCase $ do

97− let context = DBC.empty

97+ let context = DBC.empty

98+ (graph,_) <- freshTransactionGraph context

99+ let reenv = mkRelationalExprEnv context graph

98− case runReader (evalRelationalExpr (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "badAttr1" (PrimitiveTypeConstructor "Int" IntAtomType) ()]) [TupleExpr (M.singleton "badAttr2" (NakedAtomExpr (IntAtom 1)))])) (mkRelationalExprState context) of

100+ reExpr = MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "badAttr1" (PrimitiveTypeConstructor "Int" IntAtomType) ()]) [TupleExpr (M.singleton "badAttr2" (NakedAtomExpr (IntAtom 1)))]

101+ evald = runRelationalExprM reenv (evalRelationalExpr reExpr)

102+ case evald of

99 Left err -> assertEqual "tuple type mismatch" (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "badAttr2" IntAtomType])) err

103 Left err -> assertEqual "tuple type mismatch" (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "badAttr2" IntAtomType])) err

100 Right _ -> assertFailure "expected tuple type mismatch"

104 Right _ -> assertFailure "expected tuple type mismatch"

101

105

@@ -108,5 +112,7 @@ testDuplicateAttributes = TestCase $ do

108

112

109testExistingRelationType :: Test

113testExistingRelationType :: Test

110testExistingRelationType = TestCase $ do

114testExistingRelationType = TestCase $ do

115+ (graph, _) <- freshTransactionGraph dateExamples

111− let typeResult = runReader (typeForRelationalExpr (ExistingRelation relationTrue)) (RelationalExprStateElems DBC.empty)

116+ let typeResult = runRelationalExprM reenv (typeForRelationalExpr (ExistingRelation relationTrue))

117+ reenv = mkRelationalExprEnv dateExamples graph

112 assertEqual "ExistingRelation with tuples type" (Right relationFalse) typeResult

118 assertEqual "ExistingRelation with tuples type" (Right relationFalse) typeResult

test/Relation/StaticOptimizer.hs+76−51

@@ -1,13 +1,12 @@

1import ProjectM36.Base

2import ProjectM36.Relation

3−import ProjectM36.RelationalExpression

3+import ProjectM36.TransactionGraph

4import ProjectM36.DateExamples

5−import ProjectM36.Error

6import ProjectM36.TupleSet

5import ProjectM36.TupleSet

7import ProjectM36.StaticOptimizer

6import ProjectM36.StaticOptimizer

7+import ProjectM36.DatabaseContext as DBC

8import System.Exit

9import Control.Monad.State

10−import Control.Monad.Trans.Reader

11import Test.HUnit

10import Test.HUnit

12import qualified Data.Set as S

11import qualified Data.Set as S

@@ -16,100 +15,126 @@ main = do

16 tcounts <- runTestTT (TestList tests)

15 tcounts <- runTestTT (TestList tests)

17 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

16 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

18 where

17 where

19− tests = relationOptTests ++ databaseOptTests ++ [testTransitiveOptimization,

18+ tests = [testTransitiveOptimization,

20− testImpossiblePredicates,

19+ testImpossiblePredicates,

21− testJoinElimination,

20+ testJoinElimination,

22− testRestrictionPredicateCollapse,

21+ testRestrictionPredicateCollapse,

23− testPushDownRestrictionPredicate]

22+ testPushDownRestrictionPredicate,

24− optDBCTest = map (\(name, expr, unopt) -> TestCase $ assertEqual name expr (evalState (applyStaticDatabaseOptimization unopt) (freshDatabaseState dateExamples)))

23+ testOptimizeRelationalExpr,

25− relvar nam = RelationVariable nam ()

24+ testOptimizeDatabaseContextExpr]

26− startState = mkRelationalExprState dateExamples

25+

27− optRelTest = map (\(name, expr, unopt) -> TestCase $ assertEqual name expr (runReader (applyStaticRelationalOptimization unopt) startState))

26+testOptimizeDatabaseContextExpr :: Test

28− relationOptTests = optRelTest [

27+testOptimizeDatabaseContextExpr = TestCase $ do

29− ("StaticProject", Right $ relvar "s", Project (AttributeNames (attributeNames suppliersRel)) (relvar "s")),

28+ (graph, transId) <- freshTransactionGraph DBC.empty

30− ("StaticUnion", Right $ relvar "s", Union (relvar "s") (relvar "s")),

29+ let relvar nam = RelationVariable nam ()

31− ("StaticJoin", Right $ relvar "s", Join (relvar "s") (relvar "s"))

30+ relvarId nam = RelationVariable nam UncommittedContextMarker

32− ]

31+ testInfos = [

33− databaseOptTests = optDBCTest [

34− ("StaticAssign",

32+ ("StaticAssign",

35− Right $ Assign "z" (relvar "s"),

33+ Right $ Assign "z" (relvarId "s"),

36− Assign "z" (Restrict TruePredicate (relvar "s"))

34+ Assign "z" (Restrict TruePredicate (relvar "s"))

37− ),

35+ ),

38− ("StaticMultipleExpr",

36+ ("StaticMultipleExpr",

39− Right $ MultipleExpr [Assign "z" (relvar "s"),

37+ Right $ MultipleExpr [Assign "z" (relvarId "s"),

40− Assign "z" (relvar "s")],

38+ Assign "z" (relvarId "s")],

41− MultipleExpr [Assign "z" (Restrict TruePredicate (relvar "s")),

39+ MultipleExpr [Assign "z" (Restrict TruePredicate (relvar "s")),

42− Assign "z" (Restrict TruePredicate (relvar "s"))])

40+ Assign "z" (Restrict TruePredicate (relvar "s"))])

43− ]

41+ ]

42+ forM_ testInfos $ \(name, expectedExpr, unoptExpr) -> do

43+ let optExpr = runGraphRefSOptDatabaseContextExprM transId dateExamples graph (optimizeDatabaseContextExpr unoptExpr)

44+ assertEqual name expectedExpr optExpr

45testTransitiveOptimization :: Test

46testTransitiveOptimization :: Test

46testTransitiveOptimization = TestCase $ do

47testTransitiveOptimization = TestCase $ do

48+ (graph, _) <- freshTransactionGraph dateExamples

47 let expr atomexpr = AndPredicate (AttributeEqualityPredicate "a" (NakedAtomExpr (IntegerAtom 300))) (AttributeEqualityPredicate "b" atomexpr)

49 let expr atomexpr = AndPredicate (AttributeEqualityPredicate "a" (NakedAtomExpr (IntegerAtom 300))) (AttributeEqualityPredicate "b" atomexpr)

48 exprIn = expr (AttributeAtomExpr "a")

50 exprIn = expr (AttributeAtomExpr "a")

49 exprOut = expr (NakedAtomExpr (IntegerAtom 300))

51 exprOut = expr (NakedAtomExpr (IntegerAtom 300))

52+ optExpr = runGraphRefSOptRelationalExprM Nothing graph (applyStaticPredicateOptimization exprIn)

50− assertEqual "transitive property" (Right exprOut) (runReader (applyStaticPredicateOptimization exprIn) (RelationalExprStateElems dateExamples))

53+ assertEqual "transitive property" (Right exprOut) optExpr

51−

54+

52−optRelExpr :: RelationalExpr -> Either RelationalError RelationalExpr

55+

53−optRelExpr expr = runReader (applyStaticRelationalOptimization expr) (RelationalExprStateElems dateExamples)

56+testOptimizeRelationalExpr :: Test

57+testOptimizeRelationalExpr = TestCase $ do

58+ (graph, _) <- freshTransactionGraph dateExamples

59+ let relvarId nam = RelationVariable nam UncommittedContextMarker

60+ relationOptTests = [

61+ ("StaticProject",

62+ Right $ relvarId "s",

63+ Project (AttributeNames (attributeNames suppliersRel)) (relvarId "s")),

64+ ("StaticUnion",

65+ Right $ relvarId "s",

66+ Union (relvarId "s") (relvarId "s")),

67+ ("StaticJoin",

68+ Right $ relvarId "s",

69+ Join (relvarId "s") (relvarId "s"))

70+ ]

71+ forM_ relationOptTests $ \(name, expr, unoptExpr) -> do

72+ let optExpr = runGraphRefSOptRelationalExprM (Just dateExamples) graph (optimizeGraphRefRelationalExpr unoptExpr)

73+ assertEqual name expr optExpr

55testImpossiblePredicates :: Test

75testImpossiblePredicates :: Test

56testImpossiblePredicates = TestCase $ do

76testImpossiblePredicates = TestCase $ do

77+ (graph, _) <- freshTransactionGraph dateExamples

57 let tautTrue = Restrict (AtomExprPredicate (NakedAtomExpr (BoolAtom True))) rel

78 let tautTrue = Restrict (AtomExprPredicate (NakedAtomExpr (BoolAtom True))) rel

58 tautTrue2 = Restrict TruePredicate rel

79 tautTrue2 = Restrict TruePredicate rel

59 tautFalse = Restrict (AtomExprPredicate (NakedAtomExpr (BoolAtom False))) rel

80 tautFalse = Restrict (AtomExprPredicate (NakedAtomExpr (BoolAtom False))) rel

60 tautFalse2 = Restrict (NotPredicate TruePredicate) rel

81 tautFalse2 = Restrict (NotPredicate TruePredicate) rel

61 emptyRel = MakeStaticRelation (attributes suppliersRel) emptyTupleSet

82 emptyRel = MakeStaticRelation (attributes suppliersRel) emptyTupleSet

62− rel = RelationVariable "s" ()

83+ rel = RelationVariable "s" UncommittedContextMarker

84+ optRelExpr expr = optimizeGraphRefRelationalExpr' (Just dateExamples) graph expr

63 assertEqual "remove tautology where true" (Right rel) (optRelExpr tautTrue)

85 assertEqual "remove tautology where true" (Right rel) (optRelExpr tautTrue)

64 assertEqual "remove tautology where true2" (Right rel) (optRelExpr tautTrue2)

86 assertEqual "remove tautology where true2" (Right rel) (optRelExpr tautTrue2)

65 assertEqual "remove tautology where false" (Right emptyRel) (optRelExpr tautFalse)

87 assertEqual "remove tautology where false" (Right emptyRel) (optRelExpr tautFalse)

66 assertEqual "remove tautology where false2" (Right emptyRel) (optRelExpr tautFalse2)

88 assertEqual "remove tautology where false2" (Right emptyRel) (optRelExpr tautFalse2)

67−

68−optJoinExpr :: RelationalExpr -> Either RelationalError RelationalExpr

69−optJoinExpr expr = runReader (applyStaticJoinElimination expr) (RelationalExprStateElems dateExamples)

71testJoinElimination :: Test

90testJoinElimination :: Test

72testJoinElimination = TestCase $ do

91testJoinElimination = TestCase $ do

92+ (graph, _) <- freshTransactionGraph dateExamples

93+ let marker = UncommittedContextMarker

94+ optJoinExpr expr = runGraphRefSOptRelationalExprM (Just dateExamples) graph (applyStaticJoinElimination expr)

95+ relvar rv = RelationVariable rv marker

96+

73 -- (s join sp){s#,qty,p#} == sp

97 -- (s join sp){s#,qty,p#} == sp

74− let unoptExpr = Project (AttributeNames (S.fromList ["p#", "qty", "s#"])) (Join (RelationVariable "sp" ()) (RelationVariable "s" ()))

98+ let unoptExpr = Project (AttributeNames (S.fromList ["p#", "qty", "s#"])) (Join (relvar "sp") (relvar "s"))

75− assertEqual "remove extraneous join" (Right (RelationVariable "sp" ())) (optJoinExpr unoptExpr)

99+ assertEqual "remove extraneous join" (Right (relvar "sp")) (optJoinExpr unoptExpr)

100

77-- (sp join s){s#,qty,p#} == sp --flip relvar names

101-- (sp join s){s#,qty,p#} == sp --flip relvar names

78− let unoptExpr2 = Project (AttributeNames (S.fromList ["p#", "qty", "s#"])) (Join (RelationVariable "s" ()) (RelationVariable "sp" ()))

102+ let unoptExpr2 = Project (AttributeNames (S.fromList ["p#", "qty", "s#"])) (Join (relvar "s") (relvar "sp"))

79− assertEqual "remove extraneous join2" (Right (RelationVariable "sp" ())) (optJoinExpr unoptExpr2)

103+ assertEqual "remove extraneous join2" (Right (relvar "sp")) (optJoinExpr unoptExpr2)

104

81-- (sp join s){s#,qty,sname} != sp - attribute from s included

105-- (sp join s){s#,qty,sname} != sp - attribute from s included

82− let expr3 = Project (AttributeNames (S.fromList ["p#", "qty", "sname"])) (Join (RelationVariable "sp" ()) (RelationVariable "s" ()))

106+ let expr3 = Project (AttributeNames (S.fromList ["p#", "qty", "sname"])) (Join (relvar "sp") (relvar "s"))

83 assertEqual "retain join" (Right expr3) (optJoinExpr expr3)

107 assertEqual "retain join" (Right expr3) (optJoinExpr expr3)

108

85 -- (sp join s){qty} != sp --projection does not include foreign key attribute

109 -- (sp join s){qty} != sp --projection does not include foreign key attribute

86− let expr4 = Project (AttributeNames (S.singleton "qty")) (Join (RelationVariable "sp" ()) (RelationVariable "s" ()))

110+ let expr4 = Project (AttributeNames (S.singleton "qty")) (Join (relvar "sp") (relvar "s"))

87 assertEqual "retain join2" (Right expr4) (optJoinExpr expr4)

111 assertEqual "retain join2" (Right expr4) (optJoinExpr expr4)

112

89 -- (sp join s){s#,qty} == sp - a subset of attributes in the projection are in the foreign key

113 -- (sp join s){s#,qty} == sp - a subset of attributes in the projection are in the foreign key

90− let expr5 = Project (AttributeNames (S.fromList ["s#", "qty"])) (Join (RelationVariable "sp" ()) (RelationVariable "s" ()))

114+ let expr5 = Project (AttributeNames (S.fromList ["s#", "qty"])) (Join (relvar "sp") (relvar "s"))

91− let expect5 = Project (AttributeNames (S.fromList ["s#", "qty"])) (RelationVariable "sp" ())

115+ let expect5 = Project (AttributeNames (S.fromList ["s#", "qty"])) (relvar "sp")

92 assertEqual "remove extraneous join (attribute subset)" (Right expect5) (optJoinExpr expr5)

116 assertEqual "remove extraneous join (attribute subset)" (Right expect5) (optJoinExpr expr5)

117

94 -- (s join p){s#,p#} != sp -- no foreign key

118 -- (s join p){s#,p#} != sp -- no foreign key

95− let expr6 = Project (AttributeNames (S.fromList ["s#", "p#"])) (Join (RelationVariable "s" ()) (RelationVariable "p" ()))

119+ let expr6 = Project (AttributeNames (S.fromList ["s#", "p#"])) (Join (relvar "s") (relvar "p"))

96 assertEqual "retain join- no foreign key" (Right expr6) (optJoinExpr expr6)

120 assertEqual "retain join- no foreign key" (Right expr6) (optJoinExpr expr6)

121

98 -- (s join p){s#,qty,p#,sname} != sp -- all sp attributes plus one s attributes

122 -- (s join p){s#,qty,p#,sname} != sp -- all sp attributes plus one s attributes

99− let expr7 = Project (AttributeNames (S.fromList ["s#", "p#", "qty", "sname"])) (Join (RelationVariable "s" ()) (RelationVariable "sp" ()))

123+ let expr7 = Project (AttributeNames (S.fromList ["s#", "p#", "qty", "sname"])) (Join (relvar "s") (relvar "sp"))

100 assertEqual "retain join- attributes from both relvars" (Right expr7) (optJoinExpr expr7)

124 assertEqual "retain join- attributes from both relvars" (Right expr7) (optJoinExpr expr7)

101

125

102testRestrictionPredicateCollapse :: Test

126testRestrictionPredicateCollapse :: Test

103testRestrictionPredicateCollapse = TestCase $ do

127testRestrictionPredicateCollapse = TestCase $ do

104 let expr1 = Restrict (NotPredicate TruePredicate) rv

128 let expr1 = Restrict (NotPredicate TruePredicate) rv

105− rv = RelationVariable "a" ()

129+ rv = RelationVariable "a" UncommittedContextMarker

130+ relvar name = RelationVariable name UncommittedContextMarker

106 assertEqual "one restriction" expr1 (applyStaticRestrictionCollapse expr1)

131 assertEqual "one restriction" expr1 (applyStaticRestrictionCollapse expr1)

107

132

108 let attrEqualsPred = AttributeEqualityPredicate "x" (NakedAtomExpr (IntAtom 3))

133 let attrEqualsPred = AttributeEqualityPredicate "x" (NakedAtomExpr (IntAtom 3))

109− expr2 = Restrict TruePredicate (Restrict attrEqualsPred (RelationVariable "a" ()))

134+ expr2 = Restrict TruePredicate (Restrict attrEqualsPred (relvar "a"))

110− assertEqual "two restrictions" (Restrict (AndPredicate TruePredicate attrEqualsPred) (RelationVariable "a" ())) (applyStaticRestrictionCollapse expr2)

135+ assertEqual "two restrictions" (Restrict (AndPredicate TruePredicate attrEqualsPred) (relvar "a")) (applyStaticRestrictionCollapse expr2)

111

136

112− let expr3 = Restrict pred1 (Restrict pred2 (Restrict pred3 (RelationVariable "a" ())))

137+ let expr3 = Restrict pred1 (Restrict pred2 (Restrict pred3 (relvar "a")))

113 pred1 = NotPredicate TruePredicate

138 pred1 = NotPredicate TruePredicate

114 pred2 = attrEqualsPred

139 pred2 = attrEqualsPred

115 pred3 = AtomExprPredicate (NakedAtomExpr (BoolAtom True))

140 pred3 = AtomExprPredicate (NakedAtomExpr (BoolAtom True))

@@ -123,7 +148,7 @@ testRestrictionPredicateCollapse = TestCase $ do

123testPushDownRestrictionPredicate :: Test

148testPushDownRestrictionPredicate :: Test

124testPushDownRestrictionPredicate = TestCase $ do

149testPushDownRestrictionPredicate = TestCase $ do

125 -- (s union relation{tuple{city "Boston", s# "S6", sname "Stevens", status 50}}) where status = 30 == (s where status=30) union (relation{tuple{city "Boston", s# "S6", sname "Stevens", status 50}} where status=30)

150 -- (s union relation{tuple{city "Boston", s# "S6", sname "Stevens", status 50}}) where status = 30 == (s where status=30) union (relation{tuple{city "Boston", s# "S6", sname "Stevens", status 50}} where status=30)

126− let rvs = RelationVariable "s" ()

151+ let rvs = RelationVariable "s" UncommittedContextMarker

127 let status30 = AttributeEqualityPredicate "status" (NakedAtomExpr (IntAtom 30))

152 let status30 = AttributeEqualityPredicate "status" (NakedAtomExpr (IntAtom 30))

128 relationsOrError = do

153 relationsOrError = do

129 stevens <- mkRelationFromList (attributes suppliersRel) [[TextAtom "S6", TextAtom "Stevens", IntegerAtom 50, TextAtom "Boston"]]

154 stevens <- mkRelationFromList (attributes suppliersRel) [[TextAtom "S6", TextAtom "Stevens", IntegerAtom 50, TextAtom "Boston"]]

test/TransactionGraph/Merge.hs+2−2

@@ -62,8 +62,8 @@ basicTransactionGraph = do

62 uuidB = fakeUUID 11

63 uuidRoot = fakeUUID 1

64 rootContext = concreteDatabaseContext rootTrans

65− (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo uuidRoot S.empty testTime) rootContext) bsGraph

65+ (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo S.empty testTime) rootContext) bsGraph

66− (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo uuidRoot S.empty testTime) rootContext) bsGraph'

66+ (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo S.empty testTime) rootContext) bsGraph'

67 pure bsGraph''

69addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)

test/TutorialD/Interpreter.hs+42−19

@@ -9,6 +9,7 @@ import ProjectM36.TupleSet

9import ProjectM36.Error

10import ProjectM36.DatabaseContext

11import ProjectM36.AtomFunctions.Primitive

12+import ProjectM36.RelationalExpression

12import ProjectM36.DataTypes.Either

13import ProjectM36.DataTypes.Either

13import ProjectM36.DataTypes.Interval

14import ProjectM36.DataTypes.Interval

14import ProjectM36.DataTypes.NonEmptyList

15import ProjectM36.DataTypes.NonEmptyList

@@ -39,8 +40,9 @@ main = do

39 tcounts <- runTestTT (TestList tests)

40 tcounts <- runTestTT (TestList tests)

40 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

41 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

41 where

42 where

42− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++

43+ tests = [

43− map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [

44+ simpleRelTests

45+{- dateExampleRelTests,

44 transactionGraphBasicTest,

46 transactionGraphBasicTest,

45 transactionGraphAddCommitTest,

47 transactionGraphAddCommitTest,

46 transactionRollbackTest,

48 transactionRollbackTest,

@@ -73,9 +75,15 @@ main = do

73 testNonEmptyListType,

75 testNonEmptyListType,

74 testUnresolvedAtomTypes,

76 testUnresolvedAtomTypes,

75 testWithClause,

77 testWithClause,

76− testAtomFunctionArgumentMismatch

78+ testAtomFunctionArgumentMismatch-}

77 ]

79 ]

80+

81+simpleRelTests :: Test

82+simpleRelTests = TestCase $ do

83+ (graph, transId) <- freshTransactionGraph dateExamples

84+ mapM_ (\(tutd, expected) -> assertTutdEqual basicDatabaseContext transId graph expected tutd) testTups

85+ where

78− simpleRelTests = [("x:=true", Right relationTrue),

86+ testTups = [("x:=true", Right relationTrue),

79 ("x:=false", Right relationFalse),

87 ("x:=false", Right relationFalse),

80 ("x:=true union false", Right relationTrue),

88 ("x:=true union false", Right relationTrue),

81 ("x:=true minus false", Right relationTrue),

89 ("x:=true minus false", Right relationTrue),

@@ -114,24 +122,30 @@ main = do

114 simpleBAttributes = A.attributesFromList [Attribute "d" IntegerAtomType]

122 simpleBAttributes = A.attributesFromList [Attribute "d" IntegerAtomType]

115 simpleCAttributes = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" IntegerAtomType]

123 simpleCAttributes = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" IntegerAtomType]

116 simpleDAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" IntegerAtomType]

124 simpleDAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" IntegerAtomType]

117− maybeTextAtomType = ConstructedAtomType "Maybe" (M.singleton "a" TextAtomType)

125+ simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntegerAtomType]

126+ nestedRelationAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntegerAtomType])]

127+

128+dateExampleRelTests :: Test

129+dateExampleRelTests = TestCase $ do

130+ (graph, transId) <- freshTransactionGraph dateExamples

131+ mapM_ (\(tutd, expected) -> assertTutdEqual dateExamples transId graph expected tutd) testTups

132+ where

133+ simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)]

118 maybeIntegerAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntegerAtomType)

134 maybeIntegerAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntegerAtomType)

135+ maybeTextAtomType = ConstructedAtomType "Maybe" (M.singleton "a" TextAtomType)

119 simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" maybeTextAtomType]

136 simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" maybeTextAtomType]

120 simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" maybeIntegerAtomType]

137 simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" maybeIntegerAtomType]

121− simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)]

122− simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntegerAtomType]

123− nestedRelationAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntegerAtomType])]

124− extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (R.attributes suppliersRel)]

125 byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]

138 byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]

126− groupCountAttrs = A.attributesFromList [Attribute "z" IntegerAtomType]

127 minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntegerAtomType]

139 minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntegerAtomType]

140+ groupCountAttrs = A.attributesFromList [Attribute "z" IntegerAtomType]

128 updateParisPlus10 = relMap (\tuple -> do

141 updateParisPlus10 = relMap (\tuple -> do

129 statusAtom <- atomForAttributeName "status" tuple

142 statusAtom <- atomForAttributeName "status" tuple

130 cityAtom <- atomForAttributeName "city" tuple

143 cityAtom <- atomForAttributeName "city" tuple

131 if cityAtom == TextAtom "Paris" then

144 if cityAtom == TextAtom "Paris" then

132 Right $ updateTupleWithAtoms (M.singleton "status" (IntegerAtom (castInteger statusAtom + 10))) tuple

145 Right $ updateTupleWithAtoms (M.singleton "status" (IntegerAtom (castInteger statusAtom + 10))) tuple

133 else Right tuple) suppliersRel

146 else Right tuple) suppliersRel

147+ extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (R.attributes suppliersRel)]

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

148+ testTups = [("x:=s where true", Right suppliersRel),

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

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

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

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

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

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

@@ -174,14 +188,17 @@ main = do

174 ("x:=relation{tuple{a fromGregorian(2017,05,30)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DayAtomType]) [[DayAtom (fromGregorian 2017 05 30)]])

188 ("x:=relation{tuple{a fromGregorian(2017,05,30)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DayAtomType]) [[DayAtom (fromGregorian 2017 05 30)]])

175 ]

189 ]

176

190

177−assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> Text -> Assertion

191+assertTutdEqual :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError Relation -> Text -> Assertion

178−assertTutdEqual databaseContext expected tutd = assertEqual (unpack tutd) expected interpreted

192+assertTutdEqual databaseContext transId graph expected tutd = assertEqual (unpack tutd) expected interpreted

179 where

193 where

180− interpreted = case interpretDatabaseContextExpr databaseContext tutd of

194+ interpreted = case interpretDatabaseContextExpr databaseContext transId graph tutd of

181 Left err -> Left err

195 Left err -> Left err

182 Right context -> case M.lookup "x" (relationVariables context) of

196 Right context -> case M.lookup "x" (relationVariables context) of

183 Nothing -> Left $ RelVarNotDefinedError "x"

197 Nothing -> Left $ RelVarNotDefinedError "x"

184− Just rel -> Right rel

198+ Just relExpr -> do

199+ let env = freshGraphRefRelationalExprEnv (Just context) graph

200+ runGraphRefRelationalExprM env (evalGraphRefRelationalExpr relExpr)

201+

185

202

186transactionGraphBasicTest :: Test

203transactionGraphBasicTest :: Test

187transactionGraphBasicTest = TestCase $ do

204transactionGraphBasicTest = TestCase $ do

@@ -209,7 +226,7 @@ transactionGraphAddCommitTest = TestCase $ do

209 commit sessionId dbconn >>= eitherFail

226 commit sessionId dbconn >>= eitherFail

210 discon <- disconnectedTransaction_ sessionId dbconn

227 discon <- disconnectedTransaction_ sessionId dbconn

211 let context = Discon.concreteDatabaseContext discon

228 let context = Discon.concreteDatabaseContext discon

212− assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel)

229+ assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just (ExistingRelation suppliersRel))

213

230

214transactionRollbackTest :: Test

231transactionRollbackTest :: Test

215transactionRollbackTest = TestCase $ do

232transactionRollbackTest = TestCase $ do

@@ -251,12 +268,16 @@ transactionBranchTest = TestCase $ do

251

268

252-- test that overlapping attribute names with different types fail with an error

269-- test that overlapping attribute names with different types fail with an error

253failJoinTest :: Test

270failJoinTest :: Test

271+failJoinTest = TestCase $ do

272+ (graph, transId) <- freshTransactionGraph dateExamples

254−failJoinTest = TestCase $ assertTutdEqual basicDatabaseContext err "x:=relation{tuple{test 4}} join relation{tuple{test \"test\"}}"

273+ assertTutdEqual basicDatabaseContext transId graph err "x:=relation{tuple{test 4}} join relation{tuple{test \"test\"}}"

255 where

274 where

256 err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntegerAtomType]))

275 err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntegerAtomType]))

257

276

258simpleJoinTest :: Test

277simpleJoinTest :: Test

278+simpleJoinTest = TestCase $ do

279+ (graph, transId) <- freshTransactionGraph dateExamples

259−simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=s join sp"

280+ assertTutdEqual dateExamples transId graph joinedRel "x:=s join sp"

260 where

281 where

261 attrs = A.attributesFromList [Attribute "city" TextAtomType,

282 attrs = A.attributesFromList [Attribute "city" TextAtomType,

262 Attribute "qty" IntegerAtomType,

283 Attribute "qty" IntegerAtomType,

@@ -383,7 +404,9 @@ testTransGraphRelationalExpr = TestCase $ do

383 _ -> assertFailure "failed to delete branch"

404 _ -> assertFailure "failed to delete branch"

384

405

385testMultiAttributeRename :: Test

406testMultiAttributeRename :: Test

407+testMultiAttributeRename = TestCase $ do

408+ (graph, transId) <- freshTransactionGraph dateExamples

386−testMultiAttributeRename = TestCase $ assertTutdEqual dateExamples renamedRel "x:=s rename {city as town, status as price} where false"

409+ assertTutdEqual dateExamples transId graph renamedRel "x:=s rename {city as town, status as price} where false"

387 where

410 where

388 sattrs = attributesFromList [Attribute "town" TextAtomType,

411 sattrs = attributesFromList [Attribute "town" TextAtomType,

389 Attribute "sname" TextAtomType,

412 Attribute "sname" TextAtomType,

test/TutorialD/Interpreter/TestBase.hs+2−4

@@ -2,16 +2,14 @@ module TutorialD.Interpreter.TestBase where

2import ProjectM36.Client

3import TutorialD.Interpreter

4import TutorialD.Interpreter.Base

5−import qualified ProjectM36.Base as Base

6import ProjectM36.DateExamples

5import ProjectM36.DateExamples

6+import ProjectM36.DatabaseContext

7import Test.HUnit

8−import qualified Data.Map as M

9import Data.Text

8import Data.Text

11dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection)

10dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection)

12dateExamplesConnection callback = do

11dateExamplesConnection callback = do

13 dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback [])

12 dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback [])

14− let incDeps = Base.inclusionDependencies dateExamples

15 case dbconn of

13 case dbconn of

16 Left err -> error (show err)

14 Left err -> error (show err)

17 Right conn -> do

15 Right conn -> do

@@ -19,7 +17,7 @@ dateExamplesConnection callback = do

19 case eSessionId of

17 case eSessionId of

20 Left err -> error (show err)

18 Left err -> error (show err)

21 Right sessionId -> do

19 Right sessionId -> do

22− executeDatabaseContextExpr sessionId conn (databaseContextAsDatabaseContextExpr dateExamples

20+ executeDatabaseContextExpr sessionId conn (databaseContextAsDatabaseContextExpr dateExamples) >>= eitherFail

23 --skipping atom functions for now- there are no atom function manipulation operators yet

21 --skipping atom functions for now- there are no atom function manipulation operators yet

24 commit sessionId conn >>= eitherFail

22 commit sessionId conn >>= eitherFail

25 pure (sessionId, conn)

23 pure (sessionId, conn)