8c305bd · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP compilation checkpoint

8c305bdAgentM7 years ago

project-m36.cabal+5−1

compare with master

unifiedsplit

@@ -102,7 +102,11 @@ Library

102 ProjectM36.TypeConstructorDef,

103 ProjectM36.FileLock,

104 ProjectM36.FSType,

105− ProjectM36.Arbitrary

105+ ProjectM36.Arbitrary,

106+ ProjectM36.GraphRefRelationalExpr,

107+ ProjectM36.NormalizeExpr,

108+ ProjectM36.TransactionInfo,

109+ ProjectM36.WithNameExpr

106 GHC-Options: -Wall -rdynamic

110 GHC-Options: -Wall -rdynamic

107 if os(windows)

111 if os(windows)

108 Build-Depends: Win32 >= 2.5.4.1

112 Build-Depends: Win32 >= 2.5.4.1

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+2−1

@@ -186,13 +186,14 @@ executeDatabaseContextFunctionP = do

186databaseExprOpP :: Parser DatabaseContextExpr

187databaseExprOpP = multipleDatabaseContextExprP

188

189+{-

189evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext

190evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext

190evalDatabaseContextExpr useOptimizer context expr = do

191evalDatabaseContextExpr useOptimizer context expr = do

191 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) (RE.freshDatabaseState context)

192 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) (RE.freshDatabaseState context)

192 case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) (RE.freshDatabaseState context) of

193 case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) (RE.freshDatabaseState context) of

193 (Right (), (context',_, _)) -> Right context'

194 (Right (), (context',_, _)) -> Right context'

194 (Left err, _) -> Left err

195 (Left err, _) -> Left err

195−

196+-}

196

197

197interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext

198interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext

198interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of

199interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of

src/bin/TutorialD/Interpreter/RelationalExpr.hs+6−5

@@ -238,13 +238,14 @@ relationAtomExprP = RelationAtomExpr <$> makeRelationP

238withMacroExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

239withMacroExprP = do

240 reservedOp "with"

241− views <- parens (sepBy1 createViewP comma)

241+ macros <- parens (sepBy1 createMacroP comma)

242− With views <$> relExprP

242+ With macros <$> relExprP

243

244−createViewP :: RelationalMarkerExpr a => Parser (RelVarName, RelationalExprBase a)

244+createMacroP :: RelationalMarkerExpr a => Parser (WithNameExprBase a, RelationalExprBase a)

245−createViewP = do

245+createMacroP = do

246 name <- identifier

247 reservedOp "as"

248 expr <- relExprP

249+ marker <- parseMarkerP

249− pure (name, expr)

250+ pure (WithNameExpr name marker, expr)

250

251

src/lib/ProjectM36/Base.hs+12−1

@@ -215,10 +215,21 @@ data RelationalExprBase a =

215 Extend (ExtendTupleExprBase a) (RelationalExprBase a) |

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

217 --Evaluate relationalExpr with scoped views

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

218+ With [(WithNameExprBase a, RelationalExprBase a)] (RelationalExprBase a)

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

220

221instance Binary RelationalExpr

222+

223+data WithNameExprBase a = WithNameExpr RelVarName a

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

225+

226+type WithNameExpr = WithNameExprBase ()

227+

228+instance Binary WithNameExpr

229+

230+type GraphRefWithNameExpr = WithNameExprBase TransactionId

231+

232+instance Binary GraphRefWithNameExpr

222

233

223type NotificationName = StringType

234type NotificationName = StringType

224type Notifications = M.Map NotificationName Notification

235type Notifications = M.Map NotificationName Notification

src/lib/ProjectM36/Client.hs+7−7

@@ -114,7 +114,6 @@ import qualified ProjectM36.DataFrame as DF

114import ProjectM36.DatabaseContextFunction as DCF

115import qualified ProjectM36.IsomorphicSchema as Schema

116import Control.Monad.State

117−import Control.Monad.Trans.Reader

118import qualified ProjectM36.RelationalExpression as RE

117import qualified ProjectM36.RelationalExpression as RE

119import ProjectM36.DatabaseContext (basicDatabaseContext)

118import ProjectM36.DatabaseContext (basicDatabaseContext)

120import qualified ProjectM36.TransactionGraph as Graph

119import qualified ProjectM36.TransactionGraph as Graph

@@ -125,6 +124,7 @@ import ProjectM36.Attribute

125import ProjectM36.TransGraphRelationalExpression as TGRE (TransGraphRelationalExpr)

124import ProjectM36.TransGraphRelationalExpression as TGRE (TransGraphRelationalExpr)

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

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

127import ProjectM36.FileLock

126import ProjectM36.FileLock

127+import ProjectM36.NormalizeExpr

128import ProjectM36.Notifications

129import ProjectM36.Server.RemoteCallTypes

130import qualified ProjectM36.DisconnectedTransaction as Discon

@@ -599,7 +599,7 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither

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

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

603 Left err -> pure (Left err)

604 Right newState ->

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

@@ -877,9 +877,10 @@ typeForRelationalExprSTM sessionId (InProcessConnection conf) relExpr = do

877 case processed of

878 Left err -> pure (Left err)

879 Right relExpr' -> do

880+ graph <- readTVar (ipTransactionGraph conf)

880 let transId = Sess.parentId session

881 let transId = Sess.parentId session

881− graph <- readTVar (ipTransactionGraph conf)

882+ reEnv = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) transId graph

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

883+ pure $ RE.runRelationalExprM reEnv (RE.typeForRelationalExpr relExpr')

883

884

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

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

885

886

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

922 Left err -> pure $ Left err

923 Left err -> pure $ Left err

923 Right (session, _) ->

924 Right (session, _) ->

924 if schemaName session == defaultSchemaName then do

925 if schemaName session == defaultSchemaName then do

925− let env = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) transId graph

926− transId = Sess.parentId session

926+ let transId = Sess.parentId session

927− gfExpr = runReader (RE.processDatabaseContextExpr dbExpr) env

927+ gfExpr = runProcessExprM transId graph (processDatabaseContextExpr dbExpr)

928 pure $ runGraphRefStaticOptimizerMonad graph (optimizeGraphRefDatabaseContextExpr gfExpr)

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

930 pure (Left NonConcreteSchemaPlanError)

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

@@ -12,7 +12,7 @@ executeDatabaseContextExpr expr transId graph context' =

12 Left err -> error (show err)

13 where

14 env = mkDatabaseContextEvalEnv transId graph

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

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

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

18executeRelationalExpr expr context transId graph =

src/lib/ProjectM36/IsomorphicSchema.hs−1

@@ -13,7 +13,6 @@ import Data.Binary

13import qualified Data.Map as M

14import qualified Data.Set as S

15import qualified Data.List as L

16−import Control.Monad.Reader

17#if __GLASGOW_HASKELL__ <= 802

16#if __GLASGOW_HASKELL__ <= 802

18import Data.Monoid

17import Data.Monoid

19#endif

18#endif

src/lib/ProjectM36/NormalizeExpr.hs+16−10

@@ -37,7 +37,7 @@ processRelationalExpr (Rename attrA attrB expr) =

37processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB

38processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr

39processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr

40−processRelationalExpr (Restrict pred expr) = Restrict <$> processRestrictionPredicateExpr pred <*> processRelationalExpr expr

40+processRelationalExpr (Restrict pred' expr) = Restrict <$> processRestrictionPredicateExpr pred' <*> processRelationalExpr expr

41processRelationalExpr (Equals exprA exprB) =

42 Equals <$> processRelationalExpr exprA <*> processRelationalExpr exprB

43processRelationalExpr (NotEquals exprA exprB) =

@@ -45,10 +45,16 @@ processRelationalExpr (NotEquals exprA exprB) =

45processRelationalExpr (Extend extendExpr expr) =

46 Extend <$> processExtendTupleExpr extendExpr <*> processRelationalExpr expr

47processRelationalExpr (With macros expr) =

48− With <$> mapM (\(nam, wexpr) -> (,) nam <$> processRelationalExpr wexpr) macros <*> processRelationalExpr expr

48+ With <$> mapM (\(wnexpr, macroExpr) -> (,) <$> processWithNameExpr wnexpr <*> processRelationalExpr macroExpr) macros <*> processRelationalExpr expr

49+

50+processWithNameExpr :: WithNameExpr -> ProcessExprM GraphRefWithNameExpr

51+processWithNameExpr (WithNameExpr rvname ()) =

52+ WithNameExpr rvname <$> askTid

50processAttributeNames :: AttributeNames -> ProcessExprM GraphRefAttributeNames

54processAttributeNames :: AttributeNames -> ProcessExprM GraphRefAttributeNames

51processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet

55processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet

56+processAttributeNames (InvertedAttributeNames attrNameSet) =

57+ pure $ InvertedAttributeNames attrNameSet

52processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB

58processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB

53processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB

59processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB

54processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr

60processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr

@@ -61,8 +67,8 @@ processDatabaseContextExpr expr =

61 Undefine nam -> pure (Undefine nam)

67 Undefine nam -> pure (Undefine nam)

62 Assign nam rexpr -> Assign nam <$> processRelationalExpr rexpr

68 Assign nam rexpr -> Assign nam <$> processRelationalExpr rexpr

63 Insert nam rexpr -> Insert nam <$> processRelationalExpr rexpr

69 Insert nam rexpr -> Insert nam <$> processRelationalExpr rexpr

64− Delete nam pred -> Delete nam <$> processRestrictionPredicateExpr pred

70+ Delete nam pred' -> Delete nam <$> processRestrictionPredicateExpr pred'

65− Update nam attrMap pred -> Update nam attrMap <$> processRestrictionPredicateExpr pred

71+ Update nam attrMap pred' -> Update nam attrMap <$> processRestrictionPredicateExpr pred'

67 AddInclusionDependency nam dep -> pure (AddInclusionDependency nam dep)

73 AddInclusionDependency nam dep -> pure (AddInclusionDependency nam dep)

68 RemoveInclusionDependency nam -> pure (RemoveInclusionDependency nam)

74 RemoveInclusionDependency nam -> pure (RemoveInclusionDependency nam)

@@ -79,12 +85,12 @@ processDatabaseContextExpr expr =

79processDatabaseContextIOExpr :: DatabaseContextIOExpr -> ProcessExprM GraphRefDatabaseContextIOExpr

85processDatabaseContextIOExpr :: DatabaseContextIOExpr -> ProcessExprM GraphRefDatabaseContextIOExpr

80processDatabaseContextIOExpr (AddAtomFunction f tcs sc) =

86processDatabaseContextIOExpr (AddAtomFunction f tcs sc) =

81 pure (AddAtomFunction f tcs sc)

87 pure (AddAtomFunction f tcs sc)

82−processDatabaseContextIOExpr (LoadAtomFunctions mod fun file) =

88+processDatabaseContextIOExpr (LoadAtomFunctions mod' fun file) =

83− pure (LoadAtomFunctions mod fun file)

89+ pure (LoadAtomFunctions mod' fun file)

84−processDatabaseContextIOExpr (AddDatabaseContextFunction mod fun path) =

90+processDatabaseContextIOExpr (AddDatabaseContextFunction mod' fun path) =

85− pure (AddDatabaseContextFunction mod fun path)

91+ pure (AddDatabaseContextFunction mod' fun path)

86−processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod fun path) =

92+processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod' fun path) =

87− pure (LoadDatabaseContextFunctions mod fun path)

93+ pure (LoadDatabaseContextFunctions mod' fun path)

88processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =

94processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =

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

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

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

@@ -95,7 +95,7 @@ union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =

95 where

96 newtuples = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple attrs1) (asList tupSet2)

98−project :: S.Set AttributeName -> Relation -> Either RelationalError Relation

98+project :: S.Set AttributeName -> Relation -> Either RelationalError Relation

99project attrNames rel@(Relation _ tupSet) = do

100 newAttrs <- A.projectionAttributesForNames attrNames (attributes rel)

101 let newAttrNameSet = A.attributeNameSet newAttrs

src/lib/ProjectM36/RelationalExpression.hs+140−39

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

18import qualified Data.Map as M

19import qualified Data.HashSet as HS

20import qualified Data.Set as S

21−import Control.Monad.RWS.Strict as RWS

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

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

23import Control.Exception

24import Data.Maybe

@@ -27,10 +27,11 @@ import Data.Char (isUpper)

27import qualified Data.Text as T

28import qualified Data.Vector as V

29import qualified ProjectM36.TypeConstructorDef as TCD

30−import Control.Monad.Except

30+import Control.Monad.Except hiding (join)

31import Control.Monad.Trans.Except (except)

32−import Control.Monad.Reader as R

32+import Control.Monad.Reader as R hiding (join)

33import ProjectM36.NormalizeExpr

34+import ProjectM36.WithNameExpr

34import Test.QuickCheck

35import Test.QuickCheck

35import GHC

36import GHC

36import GHC.Paths

37import GHC.Paths

@@ -38,11 +39,6 @@ import Data.Time.Clock

38import Data.Time.Calendar

39import Data.Time.Calendar

39import qualified Data.List.NonEmpty as NE

40import qualified Data.List.NonEmpty as NE

40import Data.Functor.Identity

41import Data.Functor.Identity

41−import Control.Monad

42−import Control.Monad.IO.Class

43−#if __GLASGOW_HASKELL__ <= 802

44−import Data.Monoid

45−#endif

47data DatabaseContextExprDetails = CountUpdatedTuples

43data DatabaseContextExprDetails = CountUpdatedTuples

@@ -86,14 +82,12 @@ instance Show RelationalExprEnv where

86--used to eval relationalexpr

82--used to eval relationalexpr

87type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a

83type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a

85+runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either RelationalError a

86+runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))

87+

89reGraph :: RelationalExprM TransactionGraph

88reGraph :: RelationalExprM TransactionGraph

90reGraph = re_graph <$> R.ask

89reGraph = re_graph <$> R.ask

92−gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction

93−gfTransForId tid = do

94− graph <- gfGraph

95− lift $ except $ transactionForId tid graph

96−

97currentTrans :: RelationalExprM Transaction

91currentTrans :: RelationalExprM Transaction

98currentTrans = do

92currentTrans = do

99 tid <- re_currentTransId <$> R.ask

93 tid <- re_currentTransId <$> R.ask

@@ -183,6 +177,11 @@ data GraphRefRelationalExprEnv =

183

177

184type GraphRefRelationalExprM a = ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity) a

178type GraphRefRelationalExprM a = ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity) a

185

179

180+gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction

181+gfTransForId tid = do

182+ graph <- gfGraph

183+ lift $ except $ transactionForId tid graph

184+

186runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a

185runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a

187runGraphRefRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))

186runGraphRefRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))

188

187

@@ -388,7 +387,6 @@ evalGraphRefDatabaseContextExpr NoOperation = pure ()

388evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do

387evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do

389 relvars <- fmap relationVariables getStateContext

388 relvars <- fmap relationVariables getStateContext

390 tConss <- fmap typeConstructorMapping getStateContext

389 tConss <- fmap typeConstructorMapping getStateContext

391− relEnv <- dbcRelationalExprEnv

392 graph <- dbcGraph

390 graph <- dbcGraph

393 let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)

391 let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)

394 gfEnv = freshGraphRefRelationalExprEnv graph

392 gfEnv = freshGraphRefRelationalExprEnv graph

@@ -456,7 +454,7 @@ evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

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

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

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

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

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

459− restrictedPortion = Restrict pred'

457+ --TODO restrictedPortion = Restrict pred'

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

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

461 let procAtomExpr = runProcessExprM transId graph (processAtomExpr atomExpr) in

459 let procAtomExpr = runProcessExprM transId graph (processAtomExpr atomExpr) in

462 updateAttr oldname procAtomExpr accum

460 updateAttr oldname procAtomExpr accum

@@ -572,7 +570,6 @@ evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do

572

570

573evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

571evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

574 context <- getStateContext

572 context <- getStateContext

575− relExprEnv <- dbcRelationalExprEnv

576 graph <- dbcGraph

573 graph <- dbcGraph

577 --resolve atom arguments

574 --resolve atom arguments

578 let eAtomTypes = mapM (\atomExpr -> runGraphRefRelationalExprM gfEnv (typeForGraphRefAtomExpr emptyAttributes atomExpr)) atomArgExprs

575 let eAtomTypes = mapM (\atomExpr -> runGraphRefRelationalExprM gfEnv (typeForGraphRefAtomExpr emptyAttributes atomExpr)) atomArgExprs

@@ -744,7 +741,6 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

744 --create graph ref expr

741 --create graph ref expr

745 let gfExpr = Define relVarName attrExprs

742 let gfExpr = Define relVarName attrExprs

746 evalEnv = mkDatabaseContextEvalEnv (dbcio_transId env) (dbcio_graph env)

743 evalEnv = mkDatabaseContextEvalEnv (dbcio_transId env) (dbcio_graph env)

747− transId = dbcio_transId env

748 graph = dbcio_graph env

744 graph = dbcio_graph env

749 case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of

745 case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of

750 Left err -> pure (Left err)

746 Left err -> pure (Left err)

@@ -755,8 +751,8 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

755 case existingRelVar of

751 case existingRelVar of

756 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

752 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

757 Just existingRel -> do

753 Just existingRel -> do

758− let env = freshGraphRefRelationalExprEnv graph

754+ let gfEnv = freshGraphRefRelationalExprEnv graph

759− case runGraphRefRelationalExprM env (typeForGraphRefRelationalExpr existingRel) of

755+ case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr existingRel) of

760 Left err -> pure (Left err)

756 Left err -> pure (Left err)

761 Right relType -> do

757 Right relType -> do

762 let expectedAttributes = attributes relType

758 let expectedAttributes = attributes relType

@@ -793,7 +789,6 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

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

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

794

790

795 deps = inclusionDependencies context

791 deps = inclusionDependencies context

796− reEnv = mkRelationalExprEnv context transId graph

797 -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment

792 -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment

798 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

793 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

799 let process = runProcessExprM transId graph

794 let process = runProcessExprM transId graph

@@ -806,8 +801,8 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

806 typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)

801 typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)

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

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

808 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

803 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

809− gfEvald = runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr checkExpr)

804+ gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)

810− gfEnv = freshGraphRefRelationalExprEnv potentialGraph

805+ gfEnv' = freshGraphRefRelationalExprEnv potentialGraph

811 case gfEvald of

806 case gfEvald of

812 Left err -> Left err

807 Left err -> Left err

813 Right resultRel -> if resultRel == relationTrue then

808 Right resultRel -> if resultRel == relationTrue then

@@ -930,7 +925,7 @@ tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName r

930

925

931extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)

926extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)

932extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do

927extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do

933− renv <- askEnv

928+-- renv <- askEnv

934 -- check that the attribute name is not in use

929 -- check that the attribute name is not in use

935 case tupleExprCheckNewAttrName newAttrName relIn of

930 case tupleExprCheckNewAttrName newAttrName relIn of

936 Left err -> throwError err

931 Left err -> throwError err

@@ -939,7 +934,8 @@ extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrNa

939 atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType

934 atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType

940 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']

935 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']

941 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

936 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

937+ pure (newAndOldAttrs, \tup ->

942− pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in

938+ --let substate = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in

943 case unimplemented {-runReader (evalAtomExpr tup atomExpr) substate-} of

939 case unimplemented {-runReader (evalAtomExpr tup atomExpr) substate-} of

944 Left err -> Left err

940 Left err -> Left err

945 Right atom -> Right (tupleAtomExtend newAttrName atom tup)

941 Right atom -> Right (tupleAtomExtend newAttrName atom tup)

@@ -1011,6 +1007,7 @@ typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do

1011 Left _ -> case atomForAttributeName attrName envTup of

1007 Left _ -> case atomForAttributeName attrName envTup of

1012 Right atom -> pure (atomTypeForAtom atom)

1008 Right atom -> pure (atomTypeForAtom atom)

1013 Left _ -> throwError err

1009 Left _ -> throwError err

1010+ Left err -> throwError err

1014

1011

1015typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)

1012typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)

1016typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do

1013typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do

@@ -1049,6 +1046,8 @@ verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do

1049 case A.attributeForName attrName attrs' of

1046 case A.attributeForName attrName attrs' of

1050 Left err' -> throwError err'

1047 Left err' -> throwError err'

1051 Right attrType -> lift $ except $ atomTypeVerify expectedType (A.atomType attrType)

1048 Right attrType -> lift $ except $ atomTypeVerify expectedType (A.atomType attrType)

1049+ Left err -> throwError err

1050+

1052verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =

1051verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =

1053 lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)

1052 lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)

1054verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) expectedType = do

1053verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) expectedType = do

@@ -1165,14 +1164,72 @@ evalAttributeNames attrNames expr = do

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

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

1166-}

1165-}

1167

1166

1167+--temporary implementation until we have a proper planner+executor

1168evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

1169−--evalGraphRefRelationalExpr (MakeRelationaFromExprs

1169+evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1170+ mAttrs <- case mAttrExprs of

1171+ Just _ ->

1172+ Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)

1173+ Nothing -> pure Nothing

1174+ tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprs

1175+ let attrs = fromMaybe firstTupleAttrs mAttrs

1176+ firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

1177+ lift $ except $ mkRelation attrs (RelationTupleSet tuples)

1178+evalGraphRefRelationalExpr (MakeStaticRelation attributeSet tupleSet) =

1179+ lift $ except $ mkRelation attributeSet tupleSet

1180+evalGraphRefRelationalExpr (ExistingRelation rel) = pure rel

1170evalGraphRefRelationalExpr (RelationVariable name tid) = do

1181evalGraphRefRelationalExpr (RelationVariable name tid) = do

1171 ctx <- concreteDatabaseContext <$> gfTransForId tid

1182 ctx <- concreteDatabaseContext <$> gfTransForId tid

1172 case M.lookup name (relationVariables ctx) of

1183 case M.lookup name (relationVariables ctx) of

1173 Nothing -> throwError (RelVarNotDefinedError name)

1184 Nothing -> throwError (RelVarNotDefinedError name)

1174 Just rv -> evalGraphRefRelationalExpr rv

1185 Just rv -> evalGraphRefRelationalExpr rv

1175−

1186+evalGraphRefRelationalExpr (Project attrNames expr) = do

1187+ attrNameSet <- evalGraphRefAttributeNames attrNames expr

1188+ rel <- evalGraphRefRelationalExpr expr

1189+ lift $ except $ project attrNameSet rel

1190+evalGraphRefRelationalExpr (Union exprA exprB) = do

1191+ relA <- evalGraphRefRelationalExpr exprA

1192+ relB <- evalGraphRefRelationalExpr exprB

1193+ lift $ except $ union relA relB

1194+evalGraphRefRelationalExpr (Join exprA exprB) = do

1195+ relA <- evalGraphRefRelationalExpr exprA

1196+ relB <- evalGraphRefRelationalExpr exprB

1197+ lift $ except $ join relA relB

1198+evalGraphRefRelationalExpr (Rename oldName newName expr) = do

1199+ rel <- evalGraphRefRelationalExpr expr

1200+ lift $ except $ rename oldName newName rel

1201+evalGraphRefRelationalExpr (Difference exprA exprB) = do

1202+ relA <- evalGraphRefRelationalExpr exprA

1203+ relB <- evalGraphRefRelationalExpr exprB

1204+ lift $ except $ difference relA relB

1205+evalGraphRefRelationalExpr (Group groupAttrNames newAttrName expr) = do

1206+ groupNames <- evalGraphRefAttributeNames groupAttrNames expr

1207+ rel <- evalGraphRefRelationalExpr expr

1208+ lift $ except $ group groupNames newAttrName rel

1209+evalGraphRefRelationalExpr (Ungroup groupAttrName expr) = do

1210+ rel <- evalGraphRefRelationalExpr expr

1211+ lift $ except $ ungroup groupAttrName rel

1212+evalGraphRefRelationalExpr (Restrict predExpr expr) = do

1213+ rel <- evalGraphRefRelationalExpr expr

1214+ filt <- predicateRestrictionFilter (attributes rel) predExpr

1215+ lift $ except $ restrict filt rel

1216+evalGraphRefRelationalExpr (Equals exprA exprB) = do

1217+ relA <- evalGraphRefRelationalExpr exprA

1218+ relB <- evalGraphRefRelationalExpr exprB

1219+ pure $ if relA == relB then relationTrue else relationFalse

1220+evalGraphRefRelationalExpr (NotEquals exprA exprB) = do

1221+ relA <- evalGraphRefRelationalExpr exprA

1222+ relB <- evalGraphRefRelationalExpr exprB

1223+ pure $ if relA == relB then relationFalse else relationTrue

1224+evalGraphRefRelationalExpr (Extend extendTupleExpr expr) = do

1225+ rel <- evalGraphRefRelationalExpr expr

1226+ (newAttrs, tupProc) <- extendGraphRefTupleExpressionProcessor rel extendTupleExpr

1227+ lift $ except $ relMogrify tupProc newAttrs rel

1228+evalGraphRefRelationalExpr expr@With{} = do

1229+ --strategy A: add relation variables to the contexts in the graph

1230+ --strategy B: drop in macros in place (easier programmatically)

1231+ --strategy B implementation

1232+ evalGraphRefRelationalExpr (substituteWithNameMacros [] expr)

1176

1233

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

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

1178dbContextForTransId tid graph = do

1235dbContextForTransId tid graph = do

@@ -1193,28 +1250,71 @@ transactionForId tid graph

1193typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

1250typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

1194typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet

1251typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet

1195typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))

1252typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))

1196−typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =

1253+typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1197− case mAttrExprs of

1254+ mAttrs <- case mAttrExprs of

1198− Just attrExprs -> do

1255+ Just attrExprs -> do

1199− attrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs

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

1200− pure (emptyRelationWithAttrs (attributesFromList attrs))

1257+ pure (Just (attributesFromList attrs))

1258+ Nothing -> pure Nothing

1259+ tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprs

1260+ let retAttrs = case tuples of

1261+ (tup:_) -> tupleAttributes tup

1262+ [] -> fromMaybe A.emptyAttributes mAttrs

1263+ pure $ emptyRelationWithAttrs retAttrs

1264+

1201typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

1265typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

1202 relVars <- relationVariables . concreteDatabaseContext <$> gfTransForId tid

1266 relVars <- relationVariables . concreteDatabaseContext <$> gfTransForId tid

1203 case M.lookup rvName relVars of

1267 case M.lookup rvName relVars of

1204 Nothing -> throwError (RelVarNotDefinedError rvName)

1268 Nothing -> throwError (RelVarNotDefinedError rvName)

1205 Just rvExpr -> typeForGraphRefRelationalExpr rvExpr

1269 Just rvExpr -> typeForGraphRefRelationalExpr rvExpr

1206typeForGraphRefRelationalExpr (Project attrNames expr) = do

1270typeForGraphRefRelationalExpr (Project attrNames expr) = do

1207− exprType <- typeForGraphRefRelationalExpr expr

1271+ exprType' <- typeForGraphRefRelationalExpr expr

1208 projectionAttrs <- evalGraphRefAttributeNames attrNames expr

1272 projectionAttrs <- evalGraphRefAttributeNames attrNames expr

1209− lift $ except $ project projectionAttrs exprType

1273+ lift $ except $ project projectionAttrs exprType'

1210−

1274+typeForGraphRefRelationalExpr (Union exprA exprB) = do

1275+ exprA' <- typeForGraphRefRelationalExpr exprA

1276+ exprB' <- typeForGraphRefRelationalExpr exprB

1277+ lift $ except $ union exprA' exprB'

1278+typeForGraphRefRelationalExpr (Join exprA exprB) = do

1279+ exprA' <- typeForGraphRefRelationalExpr exprA

1280+ exprB' <- typeForGraphRefRelationalExpr exprB

1281+ lift $ except $ join exprA' exprB'

1282+typeForGraphRefRelationalExpr (Rename oldAttr newAttr expr) = do

1283+ expr' <- typeForGraphRefRelationalExpr expr

1284+ lift $ except $ rename oldAttr newAttr expr'

1285+typeForGraphRefRelationalExpr (Difference exprA exprB) = do

1286+ exprA' <- typeForGraphRefRelationalExpr exprA

1287+ exprB' <- typeForGraphRefRelationalExpr exprB

1288+ lift $ except $ difference exprA' exprB'

1289+typeForGraphRefRelationalExpr (Group groupNames attrName expr) = do

1290+ expr' <- typeForGraphRefRelationalExpr expr

1291+ groupNames' <- evalGraphRefAttributeNames groupNames expr

1292+ lift $ except $ group groupNames' attrName expr'

1293+typeForGraphRefRelationalExpr (Ungroup groupAttrName expr) = do

1294+ expr' <- typeForGraphRefRelationalExpr expr

1295+ lift $ except $ ungroup groupAttrName expr'

1296+typeForGraphRefRelationalExpr (Restrict pred' expr) = do

1297+ expr' <- typeForGraphRefRelationalExpr expr

1298+ filt <- predicateRestrictionFilter (attributes expr') pred'

1299+ lift $ except $ restrict filt expr'

1300+typeForGraphRefRelationalExpr Equals{} = do

1301+ pure relationFalse

1302+typeForGraphRefRelationalExpr NotEquals{} = do

1303+ pure relationFalse

1304+typeForGraphRefRelationalExpr (Extend extendTupleExpr expr) = do

1305+ rel <- typeForGraphRefRelationalExpr expr

1306+ evalGraphRefRelationalExpr (Extend extendTupleExpr (ExistingRelation rel))

1307+typeForGraphRefRelationalExpr expr@With{} = do

1308+ let expr' = substituteWithNameMacros [] expr

1309+ typeForGraphRefRelationalExpr expr'

1310+

1211evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)

1311evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)

1212evalGraphRefAttributeNames attrNames expr = do

1312evalGraphRefAttributeNames attrNames expr = do

1213− exprType <- typeForGraphRefRelationalExpr expr

1313+ exprType' <- typeForGraphRefRelationalExpr expr

1214− let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprType)))

1314+ let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprType')))

1215 case attrNames of

1315 case attrNames of

1216 AttributeNames names ->

1316 AttributeNames names ->

1217− case A.projectionAttributesForNames names (attributes exprType) of

1317+ case A.projectionAttributesForNames names (attributes exprType') of

1218 Left err -> throwError err

1318 Left err -> throwError err

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

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

1220

1320

@@ -1248,6 +1348,7 @@ evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

1248 case validateAtomType aType tConsMap of

1348 case validateAtomType aType tConsMap of

1249 Left err -> throwError err

1349 Left err -> throwError err

1250 Right _ -> pure (Attribute attrName aType)

1350 Right _ -> pure (Attribute attrName aType)

1351+evalGraphRefAttributeExpr (NakedAttributeExpr attr) = pure attr

1251

1352

1252mkEmptyRelVars :: RelationVariables -> RelationVariables

1353mkEmptyRelVars :: RelationVariables -> RelationVariables

1253mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

1354mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

@@ -1263,11 +1364,11 @@ mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

1263 mkEmptyRelVar (Difference exprA exprB) = Difference (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

1364 mkEmptyRelVar (Difference exprA exprB) = Difference (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

1264 mkEmptyRelVar (Group attrNames attrName expr) = Group attrNames attrName (mkEmptyRelVar expr)

1365 mkEmptyRelVar (Group attrNames attrName expr) = Group attrNames attrName (mkEmptyRelVar expr)

1265 mkEmptyRelVar (Ungroup attrName expr) = Ungroup attrName (mkEmptyRelVar expr)

1366 mkEmptyRelVar (Ungroup attrName expr) = Ungroup attrName (mkEmptyRelVar expr)

1266− mkEmptyRelVar (Restrict pred expr) = Restrict pred (mkEmptyRelVar expr)

1367+ mkEmptyRelVar (Restrict pred' expr) = Restrict pred' (mkEmptyRelVar expr)

1267 mkEmptyRelVar (Equals exprA exprB) = Equals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

1368 mkEmptyRelVar (Equals exprA exprB) = Equals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

1268 mkEmptyRelVar (NotEquals exprA exprB) = NotEquals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

1369 mkEmptyRelVar (NotEquals exprA exprB) = NotEquals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)

1269 mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)

1370 mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)

1270− mkEmptyRelVar (With macros expr) = With (map (\(rv, expr) -> (rv, mkEmptyRelVar expr)) macros) (mkEmptyRelVar expr)

1371+ mkEmptyRelVar (With macros expr) = With (map (\(rv, expr') -> (rv, mkEmptyRelVar expr')) macros) (mkEmptyRelVar expr)

1271

1372

1272

1373

1273dbErr :: RelationalError -> DatabaseContextEvalMonad ()

1374dbErr :: RelationalError -> DatabaseContextEvalMonad ()

src/lib/ProjectM36/StaticOptimizer.hs+6−4

@@ -35,12 +35,15 @@ optimizeAndEvalRelationalExpr env expr = do

35 optExpr <- runGraphRefStaticOptimizerMonad (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr)

36 runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

38−optimizeAndEvalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContextEvalMonad ()

38+optimizeAndEvalDatabaseContextExpr :: Bool -> DatabaseContextExpr -> DatabaseContextEvalMonad ()

39−optimizeAndEvalDatabaseContextExpr expr = do

39+optimizeAndEvalDatabaseContextExpr optimize expr = do

40 tid <- dce_transId <$> ask

41 graph <- dce_graph <$> ask

42 let gfExpr = runProcessExprM tid graph (processDatabaseContextExpr expr)

43+ eOptExpr = if optimize then

43− eOptExpr = runGraphRefStaticOptimizerMonad graph (optimizeGraphRefDatabaseContextExpr gfExpr)

44+ runGraphRefStaticOptimizerMonad graph (optimizeGraphRefDatabaseContextExpr gfExpr)

45+ else

46+ pure gfExpr

44 case eOptExpr of

47 case eOptExpr of

45 Left err -> throwError err

48 Left err -> throwError err

46 Right optExpr -> evalGraphRefDatabaseContextExpr optExpr

49 Right optExpr -> evalGraphRefDatabaseContextExpr optExpr

@@ -363,7 +366,6 @@ applyStaticJoinElimination expr@(Project attrNameSet (Join exprA exprB)) = do

363 gfSubRv = processM (processRelationalExpr subrv)

366 gfSubRv = processM (processRelationalExpr subrv)

364 gfSuperRv = processM (processRelationalExpr superrv)

367 gfSuperRv = processM (processRelationalExpr superrv)

365 processM = runProcessExprM commonTransId graph

368 processM = runProcessExprM commonTransId graph

366− gfEnv = freshGraphRefRelationalExprEnv graph

367 case runGraphRefRelationalExprM gfEnv (evalGraphRefAttributeNames gfSubAttrNames expr) of

369 case runGraphRefRelationalExprM gfEnv (evalGraphRefAttributeNames gfSubAttrNames expr) of

368 Left _ -> pure acc

370 Left _ -> pure acc

369 Right subAttrNameSet ->

371 Right subAttrNameSet ->

src/lib/ProjectM36/TransGraphRelationalExpression.hs+11−2

@@ -39,6 +39,10 @@ instance Binary TransGraphAtomExpr

40type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

42+type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup

43+

44+instance Binary TransGraphWithNameExpr

45+

42data TransGraphEvalEnv = TransGraphEvalEnv {

46data TransGraphEvalEnv = TransGraphEvalEnv {

43 tge_graph :: TransactionGraph

47 tge_graph :: TransactionGraph

44 }

48 }

@@ -108,9 +112,10 @@ processTransGraphRelationalExpr (Extend extendExpr expr) = do

108 expr' <- processTransGraphRelationalExpr expr

112 expr' <- processTransGraphRelationalExpr expr

109 pure (Extend extendExpr' expr')

113 pure (Extend extendExpr' expr')

110processTransGraphRelationalExpr (With views expr) = do

114processTransGraphRelationalExpr (With views expr) = do

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

115+ evaldViews <- mapM (\(wnexpr, vexpr) -> do

116+ wnexpr' <- processTransGraphWithNameExpr wnexpr

112 vexpr' <- processTransGraphRelationalExpr vexpr

117 vexpr' <- processTransGraphRelationalExpr vexpr

113− pure (vname, vexpr')

118+ pure (wnexpr', vexpr')

114 ) views

119 ) views

115 expr' <- processTransGraphRelationalExpr expr

120 expr' <- processTransGraphRelationalExpr expr

116 pure (With evaldViews expr')

121 pure (With evaldViews expr')

@@ -178,3 +183,7 @@ processTransGraphAttributeNames (IntersectAttributeNames namesA namesB) = do

178processTransGraphAttributeNames (RelationalExprAttributeNames expr) = do

183processTransGraphAttributeNames (RelationalExprAttributeNames expr) = do

179 evaldExpr <- processTransGraphRelationalExpr expr

184 evaldExpr <- processTransGraphRelationalExpr expr

180 pure (RelationalExprAttributeNames evaldExpr)

185 pure (RelationalExprAttributeNames evaldExpr)

186+

187+processTransGraphWithNameExpr :: TransGraphWithNameExpr -> TransGraphEvalMonad GraphRefWithNameExpr

188+processTransGraphWithNameExpr (WithNameExpr rvname tlookup) =

189+ WithNameExpr rvname <$> findTransId tlookup

src/lib/ProjectM36/TransactionInfo.hs+2−3

@@ -1,11 +1,10 @@

1module ProjectM36.TransactionInfo where

2import ProjectM36.Base

3−import qualified Data.Set as S

4import Data.Time.Clock

3import Data.Time.Clock

5import Data.List.NonEmpty

4import Data.List.NonEmpty

7-- | Create a TransactionInfo with just one parent transaction ID.

6-- | Create a TransactionInfo with just one parent transaction ID.

8singleParent :: TransactionId -> UTCTime -> TransactionInfo

7singleParent :: TransactionId -> UTCTime -> TransactionInfo

9−singleParent tid stamp = TransactionInfo {

8+singleParent tid stamp' = TransactionInfo {

10 parents = tid :| [],

9 parents = tid :| [],

11− stamp = stamp }

10+ stamp = stamp' }

src/lib/ProjectM36/WithNameExpr.hsnew file+84

@@ -0,0 +1,84 @@

1+module ProjectM36.WithNameExpr where

2+import ProjectM36.Base

4+-- substitute all instances of With-based macros to remove macro context

5+-- ideally, we would use a different relational expr type to "prove" that the with macros can no longer exist

6+type WithNameAssocs = [(GraphRefWithNameExpr, GraphRefRelationalExpr)]

7+-- | Drop macros into the relational expression wherever they are referenced.

8+substituteWithNameMacros ::

9+ WithNameAssocs ->

10+ GraphRefRelationalExpr ->

11+ GraphRefRelationalExpr

12+substituteWithNameMacros _ e@MakeRelationFromExprs{} = e

13+substituteWithNameMacros _ e@MakeStaticRelation{} = e

14+substituteWithNameMacros _ e@ExistingRelation{} = e

15+substituteWithNameMacros macros e@(RelationVariable rvname tid) =

16+ let

17+ macroFilt (WithNameExpr macroName macroTid, _) = rvname == macroName && tid== macroTid in

18+ case filter macroFilt macros of

19+ [] -> e

20+ (_,replacement):[] -> replacement

21+ _ -> error "more than one macro matched!"

22+substituteWithNameMacros macros (Project attrs expr) =

23+ Project attrs (substituteWithNameMacros macros expr)

24+substituteWithNameMacros macros (Union exprA exprB) =

25+ Union (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)

26+substituteWithNameMacros macros (Join exprA exprB) =

27+ Join (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)

28+substituteWithNameMacros macros (Rename attrA attrB expr) =

29+ Rename attrA attrB (substituteWithNameMacros macros expr)

30+substituteWithNameMacros macros (Difference exprA exprB) =

31+ Difference (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)

32+substituteWithNameMacros macros (Group attrs attr expr) =

33+ Group attrs attr (substituteWithNameMacros macros expr)

34+substituteWithNameMacros macros (Ungroup attr expr) =

35+ Ungroup attr (substituteWithNameMacros macros expr)

36+substituteWithNameMacros macros (Restrict pred' expr) =

37+ Restrict (substituteWithNameMacrosRestrictionPredicate macros pred') (substituteWithNameMacros macros expr)

38+substituteWithNameMacros macros (Equals exprA exprB) =

39+ Equals (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)

40+substituteWithNameMacros macros (NotEquals exprA exprB) =

41+ NotEquals (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)

42+substituteWithNameMacros macros (Extend extendTup expr) =

43+ Extend (substituteWitNameMacrosExtendTupleExpr macros extendTup) (substituteWithNameMacros macros expr)

44+substituteWithNameMacros macros (With moreMacros expr) =

45+ --collect and override existing macros and recurse

46+ let newMacros = foldr macroFolder macros moreMacros

47+ macroFolder (wnexpr, mexpr) acc = filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, mexpr)] in

48+ --scan for a match- if it exists, replace it (representing a with clause at a lower level

49+ substituteWithNameMacros newMacros expr

50+

51+

52+substituteWithNameMacrosRestrictionPredicate :: WithNameAssocs -> GraphRefRestrictionPredicateExpr -> GraphRefRestrictionPredicateExpr

53+substituteWithNameMacrosRestrictionPredicate macros pred' =

54+ let sub = substituteWithNameMacrosRestrictionPredicate macros in

55+ case pred' of

56+ TruePredicate -> pred'

57+ AndPredicate exprA exprB ->

58+ AndPredicate (sub exprA) (sub exprB)

59+ OrPredicate exprA exprB ->

60+ OrPredicate (sub exprA) (sub exprB)

61+ NotPredicate expr ->

62+ NotPredicate (sub expr)

63+ RelationalExprPredicate reexpr ->

64+ RelationalExprPredicate (substituteWithNameMacros macros reexpr)

65+ AtomExprPredicate atomExpr ->

66+ AtomExprPredicate (substituteWithNameMacrosAtomExpr macros atomExpr)

67+ AttributeEqualityPredicate attrName atomExpr ->

68+ AttributeEqualityPredicate attrName (substituteWithNameMacrosAtomExpr macros atomExpr)

69+

70+substituteWitNameMacrosExtendTupleExpr :: WithNameAssocs -> GraphRefExtendTupleExpr -> GraphRefExtendTupleExpr

71+substituteWitNameMacrosExtendTupleExpr macros (AttributeExtendTupleExpr attrName atomExpr) =

72+ AttributeExtendTupleExpr attrName (substituteWithNameMacrosAtomExpr macros atomExpr)

73+

74+substituteWithNameMacrosAtomExpr :: WithNameAssocs -> GraphRefAtomExpr -> GraphRefAtomExpr

75+substituteWithNameMacrosAtomExpr macros atomExpr =

76+ case atomExpr of

77+ e@AttributeAtomExpr{} -> e

78+ e@NakedAtomExpr{} -> e

79+ FunctionAtomExpr fname atomExprs tid ->

80+ FunctionAtomExpr fname (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid

81+ RelationAtomExpr reExpr ->

82+ RelationAtomExpr (substituteWithNameMacros macros reExpr)

83+ ConstructedAtomExpr dconsName atomExprs tid ->

84+ ConstructedAtomExpr dconsName (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid