c612d04 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP compilation checkpoint

c612d04AgentM7 years ago

examples/blog.hs+8−6

compare with master

unifiedsplit

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

1-- a simple example of a blog schema

2−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}

2+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings, CPP #-}

4import ProjectM36.Client

5import ProjectM36.Base

@@ -17,7 +17,9 @@ import Data.Time.Clock

17import Data.Time.Calendar

18import Control.DeepSeq

19import Data.Proxy

20+#if __GLASGOW_HASKELL__ <= 802

20import Data.Monoid

21import Data.Monoid

22+#endif

21import Data.List

23import Data.List

22import Control.Monad (when, forM_)

24import Control.Monad (when, forM_)

@@ -33,7 +35,7 @@ import Data.Time.Format

33data Blog = Blog {

35data Blog = Blog {

34 title :: T.Text,

36 title :: T.Text,

35 entry :: T.Text,

37 entry :: T.Text,

36− stamp :: UTCTime,

38+ tstamp :: UTCTime,

37 category :: Category --note that this type is an algebraic data type

39 category :: Category --note that this type is an algebraic data type

38 }

40 }

39 deriving (Generic, Show) --derive Generic so that Tupleable can use default instances

41 deriving (Generic, Show) --derive Generic so that Tupleable can use default instances

@@ -103,11 +105,11 @@ insertSampleData :: SessionId -> Connection -> IO ()

103insertSampleData sessionId conn = do

105insertSampleData sessionId conn = do

104 let blogs = [Blog { title = "Haskell Lenses",

106 let blogs = [Blog { title = "Haskell Lenses",

105 entry = "I wear Haskell rose-colored lenses.",

107 entry = "I wear Haskell rose-colored lenses.",

106− stamp = UTCTime (fromGregorian 2017 5 8) (secondsToDiffTime 1000),

108+ tstamp = UTCTime (fromGregorian 2017 5 8) (secondsToDiffTime 1000),

107 category = Food },

109 category = Food },

108 Blog { title = "Haskell Monad Analogy",

110 Blog { title = "Haskell Monad Analogy",

109 entry = "Monads are like burritos going through intestines.",

111 entry = "Monads are like burritos going through intestines.",

110− stamp = UTCTime (fromGregorian 2017 6 10) (secondsToDiffTime 2000),

112+ tstamp = UTCTime (fromGregorian 2017 6 10) (secondsToDiffTime 2000),

111 category = Cats }

113 category = Cats }

112 ]

114 ]

113 comments = [Comment { blogTitle = "Haskell Lenses",

115 comments = [Comment { blogTitle = "Haskell Lenses",

@@ -136,7 +138,7 @@ listBlogs sessionId conn = do

136 Left err -> render500 (toHtml (show err))

138 Left err -> render500 (toHtml (show err))

137 Right blogRel -> do

139 Right blogRel -> do

138 blogs <- liftIO (toList blogRel) >>= mapM (handleWebError . fromTuple) :: ActionM [Blog]

140 blogs <- liftIO (toList blogRel) >>= mapM (handleWebError . fromTuple) :: ActionM [Blog]

139− let sortedBlogs = sortBy (\b1 b2 -> stamp b1 `compare` stamp b2) blogs

141+ let sortedBlogs = sortBy (\b1 b2 -> tstamp b1 `compare` tstamp b2) blogs

140 html . renderHtml $ do

142 html . renderHtml $ do

141 h1 "Blog Posts"

143 h1 "Blog Posts"

142 forM_ sortedBlogs $ \blog -> a ! href (toValue $ "/blog/" <> title blog) $ h2 (toHtml (title blog))

144 forM_ sortedBlogs $ \blog -> a ! href (toValue $ "/blog/" <> title blog) $ h2 (toHtml (title blog))

@@ -182,7 +184,7 @@ showBlogEntry sessionId conn = do

182 render $ do

184 render $ do

183 --show blog details

185 --show blog details

184 h1 (toHtml (title blog))

186 h1 (toHtml (title blog))

185− p (toHtml ("Posted at " <> formatStamp (stamp blog) <> " under " <> show (category blog)))

187+ p (toHtml ("Posted at " <> formatStamp (tstamp blog) <> " under " <> show (category blog)))

186 p (toHtml (entry blog))

188 p (toHtml (entry blog))

187 hr

189 hr

188 h3 "Comments"

190 h3 "Comments"

project-m36.cabal−14

@@ -227,20 +227,6 @@ Executable project-m36-server

227 Default-Language: Haskell2010

228 Default-Extensions: OverloadedStrings

229

230−Executable bigrel

231− Default-Language: Haskell2010

232− Default-Extensions: OverloadedStrings

233− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups

234− Other-Modules: TutorialD.Interpreter.Base,

235− TutorialD.Interpreter.DatabaseContextExpr,

236− TutorialD.Interpreter.RelationalExpr,

237− TutorialD.Interpreter.Types

238− main-is: benchmark/bigrel.hs

239− GHC-Options: -Wall -threaded -rtsopts

240− HS-Source-Dirs: ./src/bin

241− if flag(profiler)

242− GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

243−

244Benchmark basic-benchmark

230Benchmark basic-benchmark

245 Default-Language: Haskell2010

231 Default-Language: Haskell2010

246 Default-Extensions: OverloadedStrings

232 Default-Extensions: OverloadedStrings

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+3

@@ -149,3 +149,6 @@ instance FromJSON PersistenceError

149

150instance ToJSON AtomFunctionError

151instance FromJSON AtomFunctionError

152+

153+instance ToJSON WithNameExpr

154+instance FromJSON WithNameExpr

src/bin/TutorialD/Interpreter.hs+3−1

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

1−{-# LANGUAGE GADTs, LambdaCase #-}

1+{-# LANGUAGE GADTs, LambdaCase, CPP #-}

2module TutorialD.Interpreter where

3import TutorialD.Interpreter.Base

4import TutorialD.Interpreter.RODatabaseContextOperator

@@ -28,7 +28,9 @@ import System.Console.Haskeline

28import System.Directory (getHomeDirectory)

29import qualified Data.Text as T

30import System.IO (hPutStrLn, stderr)

31+#if __GLASGOW_HASKELL__ <= 802

31import Data.Monoid

32import Data.Monoid

33+#endif

32import Data.List (isPrefixOf)

34import Data.List (isPrefixOf)

33import Control.Exception

35import Control.Exception

34import System.Exit

36import System.Exit

src/bin/TutorialD/Interpreter/Base.hs+2

@@ -35,7 +35,9 @@ import qualified Data.Text.IO as TIO

35import System.IO

36import ProjectM36.Relation.Show.Term

37import GHC.Generics

38+#if __GLASGOW_HASKELL__ <= 802

38import Data.Monoid

39import Data.Monoid

40+#endif

39import qualified Data.UUID as U

41import qualified Data.UUID as U

40import Control.Monad.Random

42import Control.Monad.Random

41import Data.List.NonEmpty as NE

43import Data.List.NonEmpty as NE

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

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

1+{-# LANGUAGE CPP #-}

1module TutorialD.Interpreter.DatabaseContextExpr where

2module TutorialD.Interpreter.DatabaseContextExpr where

2import ProjectM36.Base

3import ProjectM36.Base

3import TutorialD.Interpreter.Base

4import TutorialD.Interpreter.Base

@@ -11,7 +12,9 @@ import ProjectM36.Error

11import qualified ProjectM36.RelationalExpression as RE

12import qualified ProjectM36.RelationalExpression as RE

12import ProjectM36.Key

13import ProjectM36.Key

13import ProjectM36.FunctionalDependency

14import ProjectM36.FunctionalDependency

15+#if __GLASGOW_HASKELL__ <= 802

14import Data.Monoid

16import Data.Monoid

17+#endif

15import Data.Functor

18import Data.Functor

17--parsers which create "database expressions" which modify the database context (such as relvar assignment)

20--parsers which create "database expressions" which modify the database context (such as relvar assignment)

@@ -200,7 +203,8 @@ interpretDatabaseContextExpr context transId graph tutdstring =

200 Left err -> Left $ PM36E.ParseError (T.pack (show err))

203 Left err -> Left $ PM36E.ParseError (T.pack (show err))

201 Right parsed -> do

204 Right parsed -> do

202 let env = RE.mkDatabaseContextEvalEnv transId graph

205 let env = RE.mkDatabaseContextEvalEnv transId graph

203− RE.dbc_context <$> RE.runDatabaseContextEvalMonad context env (optimizeAndEvalDatabaseContextExpr True parsed)

206+ x <- RE.dbc_context <$> RE.runDatabaseContextEvalMonad context env (optimizeAndEvalDatabaseContextExpr True parsed)

207+ pure x

204

208

205{-

209{-

206--no optimization

210--no optimization

src/bin/TutorialD/Interpreter/Export/Base.hs+3

@@ -1,7 +1,10 @@

1+{-# LANGUAGE CPP #-}

1module TutorialD.Interpreter.Export.Base where

2module TutorialD.Interpreter.Export.Base where

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Error

4import ProjectM36.Error

5+#if __GLASGOW_HASKELL__ <= 802

4import Data.Monoid

6import Data.Monoid

7+#endif

6data RelVarDataExportOperator = RelVarDataExportOperator RelationalExpr FilePath (RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError))

9data RelVarDataExportOperator = RelVarDataExportOperator RelationalExpr FilePath (RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError))

src/bin/TutorialD/Interpreter/Import/Base.hs+3

@@ -1,7 +1,10 @@

1+{-# LANGUAGE CPP #-}

1module TutorialD.Interpreter.Import.Base where

2module TutorialD.Interpreter.Import.Base where

2import ProjectM36.Base

3import ProjectM36.Base

3import ProjectM36.Error

4import ProjectM36.Error

5+#if __GLASGOW_HASKELL__ <= 802

4import Data.Monoid

6import Data.Monoid

7+#endif

6-- | import data into a relation variable

9-- | import data into a relation variable

7data RelVarDataImportOperator = RelVarDataImportOperator RelVarName FilePath (RelVarName -> TypeConstructorMapping -> Attributes -> FilePath -> IO (Either RelationalError DatabaseContextExpr))

10data RelVarDataImportOperator = RelVarDataImportOperator RelVarName FilePath (RelVarName -> TypeConstructorMapping -> Attributes -> FilePath -> IO (Either RelationalError DatabaseContextExpr))

src/bin/TutorialD/tutd.hs+2

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

7import System.IO

8import Options.Applicative

9import System.Exit

10+#if __GLASGOW_HASKELL__ <= 802

10import Data.Monoid

11import Data.Monoid

12+#endif

11import Data.Maybe

13import Data.Maybe

12import qualified Data.Text as T

14import qualified Data.Text as T

src/bin/benchmark/bigrel.hs+14−4

@@ -4,12 +4,14 @@ import ProjectM36.Base

4import ProjectM36.Relation

5import ProjectM36.DateExamples

6import ProjectM36.Error

7+import ProjectM36.StaticOptimizer

7import qualified ProjectM36.Attribute as A

8import qualified ProjectM36.Attribute as A

8import qualified Data.Text as T

9import qualified Data.Text as T

9--import ProjectM36.Relation.Show.CSV

10--import ProjectM36.Relation.Show.CSV

10import ProjectM36.Relation.Show.HTML

11import ProjectM36.Relation.Show.HTML

11import TutorialD.Interpreter.DatabaseContextExpr (interpretDatabaseContextExpr)

12import TutorialD.Interpreter.DatabaseContextExpr (interpretDatabaseContextExpr)

12import ProjectM36.RelationalExpression

13import ProjectM36.RelationalExpression

14+import ProjectM36.TransactionGraph

13--import qualified Data.HashSet as HS

15--import qualified Data.HashSet as HS

14--import qualified Data.ByteString.Lazy.Char8 as BS

16--import qualified Data.ByteString.Lazy.Char8 as BS

15--import qualified Data.IntMap as IM

17--import qualified Data.IntMap as IM

@@ -23,6 +25,9 @@ import Control.Monad.State

23import Control.DeepSeq

25import Control.DeepSeq

24import Data.Text hiding (map)

26import Data.Text hiding (map)

25import Data.Monoid

27import Data.Monoid

28+import Data.Time.Clock

29+import Data.UUID

30+import Data.UUID.V4

27{-

32{-

28dumpcsv :: Relation -> IO ()

33dumpcsv :: Relation -> IO ()

@@ -60,13 +65,18 @@ matrixRun (BigrelArgs attributeCount tupleCount tutd) =

60 Right rel -> if tutd == "" then

65 Right rel -> if tutd == "" then

61 putStrLn "Done."

66 putStrLn "Done."

62 else do

67 else do

68+ now <- getCurrentTime

69+ tid <- nextRandom

63 let setx = Assign "x" (ExistingRelation (force rel))

70 let setx = Assign "x" (ExistingRelation (force rel))

64− (context,_,_) = execState (evalDatabaseContextExpr setx) (freshDatabaseState dateExamples)

71+ graph = bootstrapTransactionGraph now tid dateExamples

65− interpreted = interpretDatabaseContextExpr context tutd

72+ env = mkDatabaseContextEvalEnv tid graph

73+ eNewState = runDatabaseContextEvalMonad dateExamples env (optimizeAndEvalDatabaseContextExpr True setx)

66 --plan = interpretRODatabaseContextOp context $ ":showplan " ++ tutd

74 --plan = interpretRODatabaseContextOp context $ ":showplan " ++ tutd

67 --displayOpResult plan

75 --displayOpResult plan

68− case interpreted of

76+ case eNewState of

77+ Right newState -> do

78+ let ctx = dbc_context newState

69− Right context' -> TIO.putStrLn $ relationAsHTML (relationVariables context' M.! "x")

79+ TIO.putStrLn $ relationAsHTML (relationVariables ctx M.! "x")

70 Left err -> hPrint stderr err

80 Left err -> hPrint stderr err

72{-

82{-

src/lib/ProjectM36/Base.hs+33−27

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

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

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

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

4module ProjectM36.Base where

@@ -13,6 +13,7 @@ import Data.UUID (UUID)

13import Control.DeepSeq (NFData, rnf)

14import Control.DeepSeq.Generics (genericRnf)

15import GHC.Generics (Generic)

16+import GHC.Stack

16import qualified Data.Vector as V

17import qualified Data.Vector as V

17import qualified Data.List as L

18import qualified Data.List as L

18import Data.Text (Text,unpack)

19import Data.Text (Text,unpack)

@@ -216,21 +217,19 @@ data RelationalExprBase a =

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

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

217 --Evaluate relationalExpr with scoped views

218 --Evaluate relationalExpr with scoped views

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

219 With [(WithNameExprBase a, RelationalExprBase a)] (RelationalExprBase a)

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

220+ deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

220

221

221instance Binary RelationalExpr

222instance Binary RelationalExpr

222

223

223data WithNameExprBase a = WithNameExpr RelVarName a

224data WithNameExprBase a = WithNameExpr RelVarName a

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

225+ deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

225

226

226type WithNameExpr = WithNameExprBase ()

227type WithNameExpr = WithNameExprBase ()

227

228

228instance Binary WithNameExpr

229instance Binary WithNameExpr

229

230

230−type GraphRefWithNameExpr = WithNameExprBase TransactionId

231+type GraphRefWithNameExpr = WithNameExprBase GraphRefTransactionMarker

231

232

232−instance Binary GraphRefWithNameExpr

233−

234type NotificationName = StringType

233type NotificationName = StringType

235type Notifications = M.Map NotificationName Notification

234type Notifications = M.Map NotificationName Notification

236

235

@@ -276,8 +275,12 @@ data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructo

276type InclusionDependencies = M.Map IncDepName InclusionDependency

275type InclusionDependencies = M.Map IncDepName InclusionDependency

277type RelationVariables = M.Map RelVarName GraphRefRelationalExpr

276type RelationVariables = M.Map RelVarName GraphRefRelationalExpr

278

277

278+data GraphRefTransactionMarker = TransactionMarker TransactionId |

279+ UncommittedContextMarker

280+ deriving (Eq, Show, Binary, Generic, NFData, Ord)

281+

279-- a fundamental relational expr to which other relational expressions compile

282-- a fundamental relational expr to which other relational expressions compile

280−type GraphRefRelationalExpr = RelationalExprBase TransactionId

283+type GraphRefRelationalExpr = RelationalExprBase GraphRefTransactionMarker

281

284

282type SchemaName = StringType

285type SchemaName = StringType

283

286

@@ -322,7 +325,7 @@ type DatabaseContextExprName = StringType

322

325

323type DatabaseContextExpr = DatabaseContextExprBase ()

326type DatabaseContextExpr = DatabaseContextExprBase ()

324

327

325−type GraphRefDatabaseContextExpr = DatabaseContextExprBase TransactionId

328+type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker

326

329

327instance Binary GraphRefDatabaseContextExpr

330instance Binary GraphRefDatabaseContextExpr

328

331

@@ -369,13 +372,13 @@ data DatabaseContextIOExprBase a =

369 CreateArbitraryRelation RelVarName [AttributeExprBase a] Range

372 CreateArbitraryRelation RelVarName [AttributeExprBase a] Range

370 deriving (Show, Eq, Generic, Binary)

373 deriving (Show, Eq, Generic, Binary)

371

374

372−type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase TransactionId

375+type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase GraphRefTransactionMarker

373

376

374type DatabaseContextIOExpr = DatabaseContextIOExprBase ()

377type DatabaseContextIOExpr = DatabaseContextIOExprBase ()

375

378

376type RestrictionPredicateExpr = RestrictionPredicateExprBase ()

379type RestrictionPredicateExpr = RestrictionPredicateExprBase ()

377

380

378−type GraphRefRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionId

381+type GraphRefRestrictionPredicateExpr = RestrictionPredicateExprBase GraphRefTransactionMarker

379

382

380-- | Restriction predicates are boolean algebra components which, when composed, indicate whether or not a tuple should be retained during a restriction (filtering) operation.

383-- | Restriction predicates are boolean algebra components which, when composed, indicate whether or not a tuple should be retained during a restriction (filtering) operation.

381data RestrictionPredicateExprBase a =

384data RestrictionPredicateExprBase a =

@@ -386,7 +389,7 @@ data RestrictionPredicateExprBase a =

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

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

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

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

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

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

389− deriving (Show, Eq, Generic, NFData, Foldable, Functor)

392+ deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

390

393

391instance Binary RestrictionPredicateExpr

394instance Binary RestrictionPredicateExpr

392

395

@@ -448,7 +451,7 @@ instance Ord Transaction where

448

451

449type AtomExpr = AtomExprBase ()

452type AtomExpr = AtomExprBase ()

450

453

451−type GraphRefAtomExpr = AtomExprBase TransactionId

454+type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker

452

455

453-- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple.

456-- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple.

454data AtomExprBase a = AttributeAtomExpr AttributeName |

457data AtomExprBase a = AttributeAtomExpr AttributeName |

@@ -456,16 +459,16 @@ data AtomExprBase a = AttributeAtomExpr AttributeName |

456 FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |

459 FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |

457 RelationAtomExpr (RelationalExprBase a) |

460 RelationAtomExpr (RelationalExprBase a) |

458 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

461 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

459− deriving (Eq,Show,Generic, NFData, Foldable, Functor)

462+ deriving (Eq,Show,Generic, NFData, Foldable, Functor, Traversable)

460

463

461instance Binary AtomExpr

464instance Binary AtomExpr

462

465

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

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

464data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

467data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

465− deriving (Show, Eq, Generic, NFData, Foldable, Functor)

468+ deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)

466

469

467type ExtendTupleExpr = ExtendTupleExprBase ()

470type ExtendTupleExpr = ExtendTupleExprBase ()

468−type GraphRefExtendTupleExpr = ExtendTupleExprBase TransactionId

471+type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker

469

472

470instance Binary ExtendTupleExpr

473instance Binary ExtendTupleExpr

471

474

@@ -513,11 +516,11 @@ data AttributeNamesBase a = AttributeNames (S.Set AttributeName) |

513 UnionAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

516 UnionAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

514 IntersectAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

517 IntersectAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |

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

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

516− deriving (Eq, Show, Generic, NFData, Foldable, Functor)

519+ deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)

517

520

518type AttributeNames = AttributeNamesBase ()

521type AttributeNames = AttributeNamesBase ()

519

522

520−type GraphRefAttributeNames = AttributeNamesBase TransactionId

523+type GraphRefAttributeNames = AttributeNamesBase GraphRefTransactionMarker

521

524

522instance Binary AttributeNames

525instance Binary AttributeNames

523

526

@@ -528,22 +531,22 @@ data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory

528 deriving (Show, Read)

531 deriving (Show, Read)

529

532

530type AttributeExpr = AttributeExprBase ()

533type AttributeExpr = AttributeExprBase ()

531−type GraphRefAttributeExpr = AttributeExprBase TransactionId

534+type GraphRefAttributeExpr = AttributeExprBase GraphRefTransactionMarker

532

535

533-- | Create attributes dynamically.

536-- | Create attributes dynamically.

534data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

537data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

535 NakedAttributeExpr Attribute

538 NakedAttributeExpr Attribute

536− deriving (Eq, Show, Generic, Binary, NFData, Foldable, Functor)

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

537

540

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

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

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

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

540− deriving (Eq, Show, Generic, NFData, Foldable, Functor)

543+ deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)

541

544

542instance Binary TupleExpr

545instance Binary TupleExpr

543

546

544type TupleExpr = TupleExprBase ()

547type TupleExpr = TupleExprBase ()

545

548

546−type GraphRefTupleExpr = TupleExprBase TransactionId

549+type GraphRefTupleExpr = TupleExprBase GraphRefTransactionMarker

547

550

548data MergeStrategy =

551data MergeStrategy =

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

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

@@ -616,19 +619,22 @@ atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList att

616atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap

619atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap

617atomTypeVars (TypeVariableType nam) = S.singleton nam

620atomTypeVars (TypeVariableType nam) = S.singleton nam

618

621

619−unimplemented :: a

622+unimplemented :: HasCallStack => a

620unimplemented = undefined

623unimplemented = undefined

621

624

622--for serializing GraphRefRelationalExpr as part of transaction serialization

625--for serializing GraphRefRelationalExpr as part of transaction serialization

623−instance Binary (TupleExprBase TransactionId)

626+instance Binary (TupleExprBase GraphRefTransactionMarker)

624

627

625instance Binary GraphRefRelationalExpr

628instance Binary GraphRefRelationalExpr

626

629

627−instance Binary (AtomExprBase TransactionId)

630+instance Binary (AtomExprBase GraphRefTransactionMarker)

628

631

629−instance Binary (AttributeNamesBase TransactionId)

632+instance Binary (AttributeNamesBase GraphRefTransactionMarker)

630

633

631−instance Binary (RestrictionPredicateExprBase TransactionId)

634+instance Binary (RestrictionPredicateExprBase GraphRefTransactionMarker)

632

635

633−instance Binary (ExtendTupleExprBase TransactionId)

636+instance Binary (ExtendTupleExprBase GraphRefTransactionMarker)

637+

638+instance Binary GraphRefWithNameExpr

639+

634

640

src/lib/ProjectM36/Client.hs+24−19

@@ -135,8 +135,10 @@ import Control.Exception.Base

135import GHC.Conc.Sync

136

137import Network.Transport (Transport(closeTransport))

138−

139−#if MIN_VERSION_network_transport_tcp(0,6,0)

138+#if MIN_VERSION_network_transport_tcp(0,7,0)

139+import Network.Transport.TCP (createTransport, defaultTCPParameters, TCPAddr(..), TCPAddrInfo(..))

140+import Network.Transport.TCP.Internal (encodeEndPointAddress)

141+#elif MIN_VERSION_network_transport_tcp(0,6,0)

140import Network.Transport.TCP (createTransport, defaultTCPParameters)

142import Network.Transport.TCP (createTransport, defaultTCPParameters)

141import Network.Transport.TCP.Internal (encodeEndPointAddress)

143import Network.Transport.TCP.Internal (encodeEndPointAddress)

142#else

144#else

@@ -271,8 +273,15 @@ remoteDBLookupName = (++) "db-"

271

273

272createLocalNode :: IO (LocalNode, Transport)

274createLocalNode :: IO (LocalNode, Transport)

273createLocalNode = do

275createLocalNode = do

274−#if MIN_VERSION_network_transport_tcp(0,6,0)

276+#if MIN_VERSION_network_transport_tcp(0,7,0)

275− eLocalTransport <- createTransport "127.0.0.1" "0" (\sn -> ("127.0.0.1", sn)) defaultTCPParameters

277+ let addrInfo = TCPAddrInfo {

278+ tcpBindHost = "127.0.0.1",

279+ tcpBindPort = "0",

280+ tcpExternalAddress = \sn -> ("127.0.0.1", sn)

281+ }

282+ eLocalTransport <- createTransport (Addressable addrInfo) defaultTCPParameters

283+#elif MIN_VERSION_network_transport_tcp(0,6,0)

284+ eLocalTransport <- createTransport "127.0.0.1" "0" ) defaultTCPParameters

276#else

285#else

277 eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters

286 eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters

278#endif

287#endif

@@ -573,7 +582,7 @@ executeRelationalExpr sessionId (InProcessConnection conf) expr = excEither $ at

573 Right expr'' -> do

582 Right expr'' -> do

574 let graphTvar = ipTransactionGraph conf

583 let graphTvar = ipTransactionGraph conf

575 graph <- readTVar graphTvar

584 graph <- readTVar graphTvar

576− let reEnv = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) (Sess.parentId session) graph

585+ let reEnv = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) graph

577 case optimizeAndEvalRelationalExpr reEnv expr'' of

586 case optimizeAndEvalRelationalExpr reEnv expr'' of

578 Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here

587 Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here

579 Left err -> pure (Left err)

588 Left err -> pure (Left err)

@@ -685,17 +694,16 @@ executeGraphExprSTM_ freshId sessionId session sessions graphExpr graph graphTVa

685

694

686-- process notifications for commits

695-- process notifications for commits

687executeCommitExprSTM_

696executeCommitExprSTM_

688− :: TransactionId

689− -> TransactionGraph

697+ :: TransactionGraph

690 -> DatabaseContext

698 -> DatabaseContext

691 -> DatabaseContext

699 -> DatabaseContext

692 -> ClientNodes

700 -> ClientNodes

693 -> STM (EvaluatedNotifications, ClientNodes)

701 -> STM (EvaluatedNotifications, ClientNodes)

694−executeCommitExprSTM_ transId graph oldContext newContext nodes = do

702+executeCommitExprSTM_ graph oldContext newContext nodes = do

695 let nots = notifications oldContext

703 let nots = notifications oldContext

696− fireNots = notificationChanges nots transId graph oldContext newContext

704+ fireNots = notificationChanges nots graph oldContext newContext

697 evaldNots = M.map mkEvaldNot fireNots

705 evaldNots = M.map mkEvaldNot fireNots

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

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

699

707

700 mkEvaldNot notif = EvaluatedNotification { notification = notif,

708 mkEvaldNot notif = EvaluatedNotification { notification = notif,

701 reportOldRelation = evalInContext (reportOldExpr notif) oldContext,

709 reportOldRelation = evalInContext (reportOldExpr notif) oldContext,

@@ -878,8 +886,7 @@ typeForRelationalExprSTM sessionId (InProcessConnection conf) relExpr = do

878 Left err -> pure (Left err)

886 Left err -> pure (Left err)

879 Right relExpr' -> do

887 Right relExpr' -> do

880 graph <- readTVar (ipTransactionGraph conf)

888 graph <- readTVar (ipTransactionGraph conf)

881− let transId = Sess.parentId session

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

889+ let reEnv = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) graph

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

890 pure $ RE.runRelationalExprM reEnv (RE.typeForRelationalExpr relExpr')

884

891

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

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

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

923 Left err -> pure $ Left err

930 Left err -> pure $ Left err

924 Right (session, _) ->

931 Right (session, _) ->

925 if schemaName session == defaultSchemaName then do

932 if schemaName session == defaultSchemaName then do

926− let transId = Sess.parentId session

933+ let ctx = Sess.concreteDatabaseContext session

927− gfExpr = runProcessExprM transId graph (processDatabaseContextExpr dbExpr)

934+ gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr dbExpr)

928− pure $ runGraphRefStaticOptimizerMonad graph (optimizeGraphRefDatabaseContextExpr gfExpr)

935+ pure $ runGraphRefStaticOptimizerMonad (Just ctx) 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-}

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

930 pure (Left NonConcreteSchemaPlanError)

937 pure (Left NonConcreteSchemaPlanError)

931

938

@@ -960,11 +967,10 @@ relationVariablesAsRelation sessionId (InProcessConnection conf) = do

960 Left err -> pure (Left err)

967 Left err -> pure (Left err)

961 Right (session, schema) -> do

968 Right (session, schema) -> do

962 let context = Sess.concreteDatabaseContext session

969 let context = Sess.concreteDatabaseContext session

963− transId = Sess.parentId session

964 if Sess.schemaName session == defaultSchemaName then

970 if Sess.schemaName session == defaultSchemaName then

965 pure $ RE.relationVariablesAsRelation (relationVariables context) graph

971 pure $ RE.relationVariablesAsRelation (relationVariables context) graph

966 else

972 else

967− case Schema.relationVariablesInSchema schema context transId graph of

973+ case Schema.relationVariablesInSchema schema of

968 Left err -> pure (Left err)

974 Left err -> pure (Left err)

969 Right relvars -> pure $ RE.relationVariablesAsRelation relvars graph

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

970

976

@@ -1128,8 +1134,7 @@ commitLock_ sessionId conf stmBlock = do

1128 Left err -> pure $ Left err

1134 Left err -> pure $ Left err

1129 Right previousTrans ->

1135 Right previousTrans ->

1130 if not (Prelude.null transactionIdsToPersist) then do

1136 if not (Prelude.null transactionIdsToPersist) then do

1131− let transId = Sess.parentId newSession

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

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

1133 nodesToNotify <- stmSetToList nodes

1138 nodesToNotify <- stmSetToList nodes

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

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

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

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

src/lib/ProjectM36/DatabaseContext.hs+6−2

@@ -14,12 +14,16 @@ empty = DatabaseContext { inclusionDependencies = M.empty,

14 atomFunctions = HS.empty,

15 dbcFunctions = HS.empty,

16 typeConstructorMapping = [] }

17+

18+-- | Remove TransactionId markers on GraphRefRelationalExpr

19+stripGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExpr

20+stripGraphRefRelationalExpr = fmap (const ())

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

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

19databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

23databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

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

24+databaseContextAsDatabaseContextExpr context = MultipleExpr $ relVarsExprs ++ incDepsExprs ++ funcsExprs

21 where

25 where

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

26+ relVarsExprs = map (\(name, rel) -> Assign name (stripGraphRefRelationalExpr rel)) (M.toList (relationVariables context))

23 incDepsExprs :: [DatabaseContextExpr]

27 incDepsExprs :: [DatabaseContextExpr]

24 incDepsExprs = map (uncurry AddInclusionDependency) (M.toList (inclusionDependencies context))

28 incDepsExprs = map (uncurry AddInclusionDependency) (M.toList (inclusionDependencies context))

25 funcsExprs = [] -- map (\func -> ) (HS.toList funcs) -- there are no databaseExprs to add atom functions yet-}

29 funcsExprs = [] -- map (\func -> ) (HS.toList funcs) -- there are no databaseExprs to add atom functions yet-}

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

@@ -14,9 +14,9 @@ executeDatabaseContextExpr expr transId graph context' =

14 env = mkDatabaseContextEvalEnv transId graph

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

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

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

18−executeRelationalExpr expr context transId graph =

18+executeRelationalExpr expr context graph =

19 run

20 where

21− env = mkRelationalExprEnv context transId graph

21+ env = mkRelationalExprEnv context graph

22 run = optimizeAndEvalRelationalExpr env expr

src/lib/ProjectM36/Error.hs+2

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

98 | ImproperDatabaseStateError

100 | NonConcreteSchemaPlanError

101+

102+ | NoUncommittedContextInEvalError

101

103

102 | MultipleErrors [RelationalError]

104 | MultipleErrors [RelationalError]

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

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

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

@@ -20,7 +20,7 @@ eval = undefined

21-}

23−data SingularTransactionRef = SingularTransactionRef TransactionId |

23+data SingularTransactionRef = SingularTransactionRef GraphRefTransactionMarker |

24 MultipleTransactionsRef |

25 NoTransactionsRef

26 deriving (Eq, Show)

@@ -38,7 +38,7 @@ singularTransaction expr =

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

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

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

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

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

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

44 _ -> Nothing

src/lib/ProjectM36/IsomorphicSchema.hs+3−3

@@ -256,14 +256,14 @@ inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do

256inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies

257inclusionDependenciesInSchema schema incDeps = M.fromList <$> mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps)

258

259−relationVariablesInSchema :: Schema -> DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError RelationVariables

259+relationVariablesInSchema :: Schema -> Either RelationalError RelationVariables

260−relationVariablesInSchema schema@(Schema morphs) context transId graph = foldM transform M.empty morphs

260+relationVariablesInSchema schema@(Schema morphs) = foldM transform M.empty morphs

261 where

262 transform newRvMap morph = do

263 let rvNames = isomorphInRelVarNames morph

264 rvAssocs <- mapM (\rv -> do

265 expr' <- processRelationalExprInSchema schema (RelationVariable rv ())

266− let gfExpr = runProcessExprM transId graph (processRelationalExpr expr')

266+ let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr')

267 pure (rv, gfExpr)) rvNames

268 pure (M.union newRvMap (M.fromList rvAssocs))

269

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

@@ -5,18 +5,15 @@ import Control.Monad.Trans.Reader as R

5import qualified Data.Map as M

7--used to process/normalize exprs to their respective graph ref forms

8−type ProcessExprM a = Reader (TransactionGraph, TransactionId) a

8+type ProcessExprM a = Reader GraphRefTransactionMarker a

10type CurrentTransactionId = TransactionId

12−runProcessExprM :: CurrentTransactionId -> TransactionGraph -> ProcessExprM a -> a

12+runProcessExprM :: GraphRefTransactionMarker -> ProcessExprM a -> a

13−runProcessExprM tid graph m = runReader m (graph, tid)

13+runProcessExprM mtid m = runReader m mtid

15−askGraph :: ProcessExprM TransactionGraph

15+askMarker :: ProcessExprM GraphRefTransactionMarker

16−askGraph = fst <$> R.ask

16+askMarker = R.ask

17−

18−askTid :: ProcessExprM CurrentTransactionId

19−askTid = snd <$> R.ask

21-- convert a RelationalExpr into a GraphRefRelationalExpr using the current trans Id

18-- convert a RelationalExpr into a GraphRefRelationalExpr using the current trans Id

22processRelationalExpr :: RelationalExpr -> ProcessExprM GraphRefRelationalExpr

19processRelationalExpr :: RelationalExpr -> ProcessExprM GraphRefRelationalExpr

@@ -28,7 +25,7 @@ processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do

28processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)

25processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)

29processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)

26processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)

30--requires current trans id and graph

27--requires current trans id and graph

31−processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> askTid

28+processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> askMarker

32processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr

29processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr

33processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB

30processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB

34processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB

31processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB

@@ -49,7 +46,7 @@ processRelationalExpr (With macros expr) =

50processWithNameExpr :: WithNameExpr -> ProcessExprM GraphRefWithNameExpr

47processWithNameExpr :: WithNameExpr -> ProcessExprM GraphRefWithNameExpr

51processWithNameExpr (WithNameExpr rvname ()) =

48processWithNameExpr (WithNameExpr rvname ()) =

52− WithNameExpr rvname <$> askTid

49+ WithNameExpr rvname <$> askMarker

54processAttributeNames :: AttributeNames -> ProcessExprM GraphRefAttributeNames

51processAttributeNames :: AttributeNames -> ProcessExprM GraphRefAttributeNames

55processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet

52processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet

@@ -114,9 +111,9 @@ processAtomExpr :: AtomExpr -> ProcessExprM GraphRefAtomExpr

114processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam

111processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam

115processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom

112processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom

116processAtomExpr (FunctionAtomExpr fName atomExprs ()) =

113processAtomExpr (FunctionAtomExpr fName atomExprs ()) =

117− FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> askTid

114+ FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> askMarker

118processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr

115processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr

119−processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> askTid

116+processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> askMarker

120

117

121processTupleExpr :: TupleExpr -> ProcessExprM GraphRefTupleExpr

118processTupleExpr :: TupleExpr -> ProcessExprM GraphRefTupleExpr

122processTupleExpr (TupleExpr tMap) =

119processTupleExpr (TupleExpr tMap) =

@@ -125,6 +122,6 @@ processTupleExpr (TupleExpr tMap) =

125--convert AttributeExpr to GraphRefAttributeExpr

122--convert AttributeExpr to GraphRefAttributeExpr

126processAttributeExpr :: AttributeExpr -> ProcessExprM GraphRefAttributeExpr

123processAttributeExpr :: AttributeExpr -> ProcessExprM GraphRefAttributeExpr

127processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) =

124processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) =

128− AttributeAndTypeNameExpr nam tCons <$> askTid

125+ AttributeAndTypeNameExpr nam tCons <$> askMarker

129processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr

126processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr

130

127

src/lib/ProjectM36/Notifications.hs+4−4

@@ -7,13 +7,13 @@ import qualified Data.Map as M

7import Data.Either (isRight)

9-- | Returns the notifications which should be triggered based on the transition from the first 'DatabaseContext' to the second 'DatabaseContext'.

10−notificationChanges :: Notifications -> TransactionId -> TransactionGraph -> DatabaseContext -> DatabaseContext -> Notifications

10+notificationChanges :: Notifications -> TransactionGraph -> DatabaseContext -> DatabaseContext -> Notifications

11−notificationChanges nots tid graph context1 context2 = M.filter notificationFilter nots

11+notificationChanges nots graph context1 context2 = M.filter notificationFilter nots

12 where

13 notificationFilter (Notification chExpr _ _) = oldChangeEval /= newChangeEval && isRight oldChangeEval

14 where

15− oldChangeEval = evalChangeExpr chExpr (mkRelationalExprEnv context1 tid graph)

15+ oldChangeEval = evalChangeExpr chExpr (mkRelationalExprEnv context1 graph)

16− newChangeEval = evalChangeExpr chExpr (mkRelationalExprEnv context2 tid graph)

16+ newChangeEval = evalChangeExpr chExpr (mkRelationalExprEnv context2 graph)

18 evalChangeExpr :: RelationalExpr -> RelationalExprEnv -> Either RelationalError Relation

19 evalChangeExpr chExpr env =

src/lib/ProjectM36/RelationalExpression.hs+102−59

@@ -66,7 +66,6 @@ mkDatabaseContextEvalState context = DatabaseContextEvalState {

66data RelationalExprEnv = RelationalExprEnv {

67 re_context :: DatabaseContext,

68 re_graph :: TransactionGraph,

69− re_currentTransId :: TransactionId,

70 re_extra :: Maybe (Either RelationTuple Attributes)

69 re_extra :: Maybe (Either RelationTuple Attributes)

71 }

70 }

@@ -88,21 +87,14 @@ runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))

88reGraph :: RelationalExprM TransactionGraph

87reGraph :: RelationalExprM TransactionGraph

89reGraph = re_graph <$> R.ask

88reGraph = re_graph <$> R.ask

91−currentTrans :: RelationalExprM Transaction

90+reContext :: RelationalExprM DatabaseContext

92−currentTrans = do

91+reContext = re_context <$> R.ask

93− tid <- re_currentTransId <$> R.ask

94− graph <- re_graph <$> R.ask

95− lift $ except $ transactionForId tid graph

96−

97−reTransId :: RelationalExprM TransactionId

98−reTransId = re_currentTransId <$> R.ask

100−mkRelationalExprEnv :: DatabaseContext -> TransactionId -> TransactionGraph -> RelationalExprEnv

93+mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv

101−mkRelationalExprEnv ctx currentTransId graph =

94+mkRelationalExprEnv ctx graph =

102 RelationalExprEnv

95 RelationalExprEnv

103 { re_context = ctx,

96 { re_context = ctx,

104 re_graph = graph,

97 re_graph = graph,

105− re_currentTransId = currentTransId,

106 re_extra = Nothing }

98 re_extra = Nothing }

107

108askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv

100askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv

@@ -159,7 +151,7 @@ dbcGraph = dce_graph <$> RWS.ask

159

151

160dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv

152dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv

161dbcRelationalExprEnv =

153dbcRelationalExprEnv =

162− mkRelationalExprEnv <$> getStateContext <*> dbcTransId <*> dbcGraph

154+ mkRelationalExprEnv <$> getStateContext <*> dbcGraph

163

155

164getStateContext :: DatabaseContextEvalMonad DatabaseContext

156getStateContext :: DatabaseContextEvalMonad DatabaseContext

165getStateContext = dbc_context <$> get

157getStateContext = dbc_context <$> get

@@ -167,10 +159,12 @@ getStateContext = dbc_context <$> get

167putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()

159putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()

168putStateContext ctx' = do

160putStateContext ctx' = do

169 s <- get

161 s <- get

170− put (s {dbc_context = ctx'})

162+ put (s {dbc_context = ctx', dbc_dirty = True})

171−

163+

164+-- | The context is optionally passed down along in cases where the current context is uncommitted.

172data GraphRefRelationalExprEnv =

165data GraphRefRelationalExprEnv =

173 GraphRefRelationalExprEnv {

166 GraphRefRelationalExprEnv {

167+ gre_context :: Maybe DatabaseContext,

174 gre_graph :: TransactionGraph,

168 gre_graph :: TransactionGraph,

175 gre_extra :: Maybe (Either RelationTuple Attributes)

169 gre_extra :: Maybe (Either RelationTuple Attributes)

176 }

170 }

@@ -182,11 +176,20 @@ gfTransForId tid = do

182 graph <- gfGraph

176 graph <- gfGraph

183 lift $ except $ transactionForId tid graph

177 lift $ except $ transactionForId tid graph

184

178

179+gfDatabaseContextForMarker :: GraphRefTransactionMarker -> GraphRefRelationalExprM DatabaseContext

180+gfDatabaseContextForMarker (TransactionMarker transId) = concreteDatabaseContext <$> gfTransForId transId

181+gfDatabaseContextForMarker UncommittedContextMarker = do

182+ mctx <- gre_context <$> askEnv

183+ case mctx of

184+ Nothing -> throwError NoUncommittedContextInEvalError

185+ Just ctx -> pure ctx

186+

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

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

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

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

187

189

188−freshGraphRefRelationalExprEnv :: TransactionGraph -> GraphRefRelationalExprEnv

190+freshGraphRefRelationalExprEnv :: Maybe DatabaseContext -> TransactionGraph -> GraphRefRelationalExprEnv

189−freshGraphRefRelationalExprEnv graph = GraphRefRelationalExprEnv {

191+freshGraphRefRelationalExprEnv mctx graph = GraphRefRelationalExprEnv {

192+ gre_context = mctx,

190 gre_graph = graph,

193 gre_graph = graph,

191 gre_extra = Nothing

194 gre_extra = Nothing

192 }

195 }

@@ -385,11 +388,12 @@ evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContex

385evalGraphRefDatabaseContextExpr NoOperation = pure ()

388evalGraphRefDatabaseContextExpr NoOperation = pure ()

386

389

387evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do

390evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do

391+ context <- getStateContext

388 relvars <- fmap relationVariables getStateContext

392 relvars <- fmap relationVariables getStateContext

389 tConss <- fmap typeConstructorMapping getStateContext

393 tConss <- fmap typeConstructorMapping getStateContext

390 graph <- dbcGraph

394 graph <- dbcGraph

391 let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)

395 let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)

392− gfEnv = freshGraphRefRelationalExprEnv graph

396+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

393 case eAttrs of

397 case eAttrs of

394 Left err -> dbErr err

398 Left err -> dbErr err

395 Right attrsList -> do

399 Right attrsList -> do

@@ -416,7 +420,7 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

416 Just existingRel -> do

420 Just existingRel -> do

417 let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)

421 let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)

418 eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)

422 eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)

419− reEnv = freshGraphRefRelationalExprEnv graph

423+ reEnv = freshGraphRefRelationalExprEnv (Just context) graph

420 case eExpectedType of

424 case eExpectedType of

421 Left err -> dbErr err

425 Left err -> dbErr err

422 Right expectedType ->

426 Right expectedType ->

@@ -429,34 +433,32 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

429 dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))

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

430

434

431evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

435evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

432− transId <- dbcTransId

433 evalGraphRefDatabaseContextExpr (Assign relVarName

436 evalGraphRefDatabaseContextExpr (Assign relVarName

434 (Union

437 (Union

435− (RelationVariable relVarName transId)

438+ (RelationVariable relVarName UncommittedContextMarker)

436 relExpr))

439 relExpr))

437

440

438evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

441evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

439 transId <- dbcTransId

442 transId <- dbcTransId

440− let rv = RelationVariable relVarName transId

443+ let rv = RelationVariable relVarName (TransactionMarker transId)

441 setRelVar relVarName (Restrict (NotPredicate predicate) rv)

444 setRelVar relVarName (Restrict (NotPredicate predicate) rv)

442

445

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

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

444evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

447evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

445 context <- getStateContext

448 context <- getStateContext

446 transId <- dbcTransId

449 transId <- dbcTransId

447− graph <- dbcGraph

448 let relVarMap = relationVariables context

450 let relVarMap = relationVariables context

449 case M.lookup relVarName relVarMap of

451 case M.lookup relVarName relVarMap of

450 Nothing -> dbErr (RelVarNotDefinedError relVarName)

452 Nothing -> dbErr (RelVarNotDefinedError relVarName)

451 Just _ -> do

453 Just _ -> do

452 let unrestrictedPortion = Restrict (NotPredicate pred') rv

454 let unrestrictedPortion = Restrict (NotPredicate pred') rv

453− rv = RelationVariable relVarName transId

455+ rv = RelationVariable relVarName (TransactionMarker transId)

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

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

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

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

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

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

457 --TODO restrictedPortion = Restrict pred'

459 --TODO restrictedPortion = Restrict pred'

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

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

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

461+ let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in

460 updateAttr oldname procAtomExpr accum

462 updateAttr oldname procAtomExpr accum

461 ) rv (M.toList atomExprMap)

463 ) rv (M.toList atomExprMap)

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

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

@@ -535,15 +537,10 @@ evalGraphRefDatabaseContextExpr (RemoveTypeConstructor tConsName) = do

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

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

536 putStateContext $ currentContext { typeConstructorMapping = newTypes }

538 putStateContext $ currentContext { typeConstructorMapping = newTypes }

537

539

538−evalGraphRefDatabaseContextExpr (MultipleExpr _) = do

540+evalGraphRefDatabaseContextExpr (MultipleExpr exprs) = do

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

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

540− unimplemented

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

542+ mapM_ (\expr -> evalGraphRefDatabaseContextExpr expr) exprs

542− --some lifting magic needed here

543+

543− case lefts evald of

544− [] -> pure ()

545− errs -> dbErr (someErrors errs)

546− -}

547evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do

544evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do

548 currentContext <- getStateContext

545 currentContext <- getStateContext

549 let atomFuncs = atomFunctions currentContext

546 let atomFuncs = atomFunctions currentContext

@@ -574,7 +571,7 @@ evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArg

574 --resolve atom arguments

571 --resolve atom arguments

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

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

576 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

573 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

577− gfEnv = freshGraphRefRelationalExprEnv graph

574+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

578 case eFunc of

575 case eFunc of

579 Left err -> dbErr err

576 Left err -> dbErr err

580 Right func -> do

577 Right func -> do

@@ -591,8 +588,7 @@ evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArg

591 Left err -> Just err

588 Left err -> Just err

592 Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)

589 Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)

593 typeErrors = catMaybes mValidTypes

590 typeErrors = catMaybes mValidTypes

594− eAtomArgs = unimplemented

591+ eAtomArgs = map (\arg -> runGraphRefRelationalExprM gfEnv (evalGraphRefAtomExpr emptyTuple arg)) atomArgExprs

595− --eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs

596 if length (lefts eAtomArgs) > 1 then

592 if length (lefts eAtomArgs) > 1 then

597 dbErr (someErrors (lefts eAtomArgs))

593 dbErr (someErrors (lefts eAtomArgs))

598 else if not (null typeErrors) then

594 else if not (null typeErrors) then

@@ -638,7 +634,7 @@ getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv

638getDBCIORelationalExprEnv = do

634getDBCIORelationalExprEnv = do

639 context <- getDBCIOContext

635 context <- getDBCIOContext

640 env <- RWS.ask

636 env <- RWS.ask

641− pure $ mkRelationalExprEnv context (dbcio_transId env) (dbcio_graph env)

637+ pure $ mkRelationalExprEnv context (dbcio_graph env)

642

638

643evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

639evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

644evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do

640evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do

@@ -751,7 +747,7 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

751 case existingRelVar of

747 case existingRelVar of

752 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

748 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

753 Just existingRel -> do

749 Just existingRel -> do

754− let gfEnv = freshGraphRefRelationalExprEnv graph

750+ let gfEnv = freshGraphRefRelationalExprEnv (Just currentContext) graph

755 case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr existingRel) of

751 case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr existingRel) of

756 Left err -> pure (Left err)

752 Left err -> pure (Left err)

757 Right relType -> do

753 Right relType -> do

@@ -791,18 +787,18 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

791 deps = inclusionDependencies context

787 deps = inclusionDependencies context

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

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

793 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

789 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

794− let process = runProcessExprM transId graph

790+ let process = runProcessExprM UncommittedContextMarker

795 gfSubsetExpr = process (processRelationalExpr subsetExpr)

791 gfSubsetExpr = process (processRelationalExpr subsetExpr)

796 gfSupersetExpr = process (processRelationalExpr supersetExpr)

792 gfSupersetExpr = process (processRelationalExpr supersetExpr)

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

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

798− let gfEnv = freshGraphRefRelationalExprEnv graph

794+ let gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

799 runGfRel = runGraphRefRelationalExprM gfEnv

795 runGfRel = runGraphRefRelationalExprM gfEnv

800 typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)

796 typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)

801 typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)

797 typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)

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

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

803 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

799 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

804 gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)

800 gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)

805− gfEnv' = freshGraphRefRelationalExprEnv potentialGraph

801+ gfEnv' = freshGraphRefRelationalExprEnv (Just context) potentialGraph

806 case gfEvald of

802 case gfEvald of

807 Left err -> Left err

803 Left err -> Left err

808 Right resultRel -> if resultRel == relationTrue then

804 Right resultRel -> if resultRel == relationTrue then

@@ -818,9 +814,9 @@ typeForRelationalExpr expr = do

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

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

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

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

820 graph <- reGraph

816 graph <- reGraph

821− transId <- reTransId

817+ context <- reContext

822− let gfExpr = runProcessExprM transId graph (processRelationalExpr expr)

818+ let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)

823− gfEnv = freshGraphRefRelationalExprEnv graph

819+ gfEnv = freshGraphRefRelationalExprEnv (Just context) graph

824 runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

820 runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

825 lift $ except $ runGf

821 lift $ except $ runGf

826

822

@@ -934,18 +930,64 @@ extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrNa

934 atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType

930 atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType

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

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

936 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

932 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

933+ env <- ask

937− pure (newAndOldAttrs, \tup ->

934+ pure (newAndOldAttrs, \tup -> do

938− --let substate = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in

935+ let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup env

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

936+ atom <- runGraphRefRelationalExprM gfEnv (evalGraphRefAtomExpr tup atomExpr)

940− Left err -> Left err

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

937+ Right (tupleAtomExtend newAttrName atom tup)

942 )

938 )

943

939

944evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom

940evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom

945−evalGraphRefAtomExpr = unimplemented

941+evalGraphRefAtomExpr tupIn (AttributeAtomExpr attrName) =

942+ case atomForAttributeName attrName tupIn of

943+ Right atom -> pure atom

944+ Left err@(NoSuchAttributeNamesError _) -> do

945+ env <- askEnv

946+ case gre_extra env of

947+ Nothing -> throwError err

948+ Just (Left ctxtup) -> lift $ except $ atomForAttributeName attrName ctxtup

949+ Just (Right _) -> throwError err

950+ Left err -> throwError err

951+evalGraphRefAtomExpr _ (NakedAtomExpr atom) = pure atom

952+evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName arguments tid) = do

953+ argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments

954+ context <- gfDatabaseContextForMarker tid

955+ let functions = atomFunctions context

956+ func <- lift $ except (atomFunctionForName funcName functions)

957+ let expectedArgCount = length (atomFuncType func) - 1

958+ actualArgCount = length argTypes

959+ safeInit [] = [] -- different behavior from normal init

960+ safeInit xs = init xs

961+ if expectedArgCount /= actualArgCount then

962+ throwError (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

963+ else do

964+ let zippedArgs = zip (safeInit (atomFuncType func)) argTypes

965+ mapM_ (\(expType, actType) -> do

966+ lift $ except (atomTypeVerify expType actType)) zippedArgs

967+ evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments

968+ case evalAtomFunction func evaldArgs of

969+ Left err -> throwError (AtomFunctionUserError err)

970+ Right result -> do

971+ --validate that the result matches the expected type

972+ _ <- lift $ except (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))

973+ pure result

974+evalGraphRefAtomExpr tupIn (RelationAtomExpr relExpr) = do

975+ --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes

976+ env <- ask

977+ let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn env

978+ relAtom <- lift $ except $ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)

979+ pure (RelationAtom relAtom)

980+evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do --why is the tid unused here? suspicious

981+ let mergeEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn

982+ aType <- local mergeEnv (typeForGraphRefAtomExpr (tupleAttributes tupIn) cons)

983+ argAtoms <- local mergeEnv $

984+ mapM (evalGraphRefAtomExpr tupIn) dConsArgs

985+ pure (ConstructedAtom dConsName aType argAtoms)

946

986

987+{-

947evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom

988evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom

948−evalAtomExpr = unimplemented

989+evalAtomExpr tupIn expr =

990+ -}

949{-

991{-

950

992

951evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of

993evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of

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

1011

1053

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

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

1013typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do

1055typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do

1014− funcs <- atomFunctions . concreteDatabaseContext <$> gfTransForId transId

1056+ funcs <- atomFunctions <$> gfDatabaseContextForMarker transId

1015 case atomFunctionForName funcName funcs of

1057 case atomFunctionForName funcName funcs of

1016 Left err -> throwError err

1058 Left err -> throwError err

1017 Right func -> do

1059 Right func -> do

@@ -1029,7 +1071,7 @@ typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do

1029typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =

1071typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =

1030 do

1072 do

1031 argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs

1073 argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs

1032− tConsMap <- typeConstructorMapping . concreteDatabaseContext <$> gfTransForId tid

1074+ tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid

1033 lift $ except $ atomTypeForDataConstructor tConsMap dConsName argsTypes

1075 lift $ except $ atomTypeForDataConstructor tConsMap dConsName argsTypes

1034

1076

1035-- | Validate that the type of the AtomExpr matches the expected type.

1077-- | Validate that the type of the AtomExpr matches the expected type.

@@ -1051,7 +1093,7 @@ verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do

1051verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =

1093verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =

1052 lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)

1094 lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)

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

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

1054− context <- concreteDatabaseContext <$> gfTransForId tid

1096+ context <- gfDatabaseContextForMarker tid

1055 let functions = atomFunctions context

1097 let functions = atomFunctions context

1056 func <- lift $ except $ atomFunctionForName funcName functions

1098 func <- lift $ except $ atomFunctionForName funcName functions

1057 let expectedArgTypes = atomFuncType func

1099 let expectedArgTypes = atomFuncType func

@@ -1077,7 +1119,7 @@ verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do

1077-- | Look up the type's name and create a new attribute.

1119-- | Look up the type's name and create a new attribute.

1078evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute

1120evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute

1079evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do

1121evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do

1080− tConsMap <- typeConstructorMapping . concreteDatabaseContext <$> gfTransForId transId

1122+ tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker transId

1081 aType <- lift $ except $ atomTypeForTypeConstructorValidate True tCons tConsMap M.empty

1123 aType <- lift $ except $ atomTypeForTypeConstructorValidate True tCons tConsMap M.empty

1082 lift $ except $ validateAtomType aType tConsMap

1124 lift $ except $ validateAtomType aType tConsMap

1083 pure $ Attribute attrName aType

1125 pure $ Attribute attrName aType

@@ -1179,7 +1221,7 @@ evalGraphRefRelationalExpr (MakeStaticRelation attributeSet tupleSet) =

1179 lift $ except $ mkRelation attributeSet tupleSet

1221 lift $ except $ mkRelation attributeSet tupleSet

1180evalGraphRefRelationalExpr (ExistingRelation rel) = pure rel

1222evalGraphRefRelationalExpr (ExistingRelation rel) = pure rel

1181evalGraphRefRelationalExpr (RelationVariable name tid) = do

1223evalGraphRefRelationalExpr (RelationVariable name tid) = do

1182− ctx <- concreteDatabaseContext <$> gfTransForId tid

1224+ ctx <- gfDatabaseContextForMarker tid

1183 case M.lookup name (relationVariables ctx) of

1225 case M.lookup name (relationVariables ctx) of

1184 Nothing -> throwError (RelVarNotDefinedError name)

1226 Nothing -> throwError (RelVarNotDefinedError name)

1185 Just rv -> evalGraphRefRelationalExpr rv

1227 Just rv -> evalGraphRefRelationalExpr rv

@@ -1263,7 +1305,7 @@ typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1263 pure $ emptyRelationWithAttrs retAttrs

1305 pure $ emptyRelationWithAttrs retAttrs

1264

1306

1265typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

1307typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

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

1308+ relVars <- relationVariables <$> gfDatabaseContextForMarker tid

1267 case M.lookup rvName relVars of

1309 case M.lookup rvName relVars of

1268 Nothing -> throwError (RelVarNotDefinedError rvName)

1310 Nothing -> throwError (RelVarNotDefinedError rvName)

1269 Just rvExpr -> typeForGraphRefRelationalExpr rvExpr

1311 Just rvExpr -> typeForGraphRefRelationalExpr rvExpr

@@ -1341,7 +1383,7 @@ evalGraphRefAttributeNames attrNames expr = do

1341

1383

1342evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute

1384evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute

1343evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

1385evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

1344− tConsMap <- typeConstructorMapping . concreteDatabaseContext <$> gfTransForId tid

1386+ tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid

1345 case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of

1387 case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of

1346 Left err -> throwError err

1388 Left err -> throwError err

1347 Right aType -> do

1389 Right aType -> do

@@ -1381,7 +1423,7 @@ relationVariablesAsRelation relVarMap graph = do

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

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

1382 Attribute "attributes" (RelationAtomType subrelAttrs)]

1424 Attribute "attributes" (RelationAtomType subrelAttrs)]

1383 mkRvDesc (rvName, gfExpr) = do

1425 mkRvDesc (rvName, gfExpr) = do

1384− let gfEnv = freshGraphRefRelationalExprEnv graph

1426+ let gfEnv = freshGraphRefRelationalExprEnv Nothing graph

1385 gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

1427 gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

1386 pure (rvName, gfType)

1428 pure (rvName, gfType)

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

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

@@ -1393,3 +1435,4 @@ relationVariablesAsRelation relVarMap graph = do

1393 let tups = map relVarToAtomList rvs

1435 let tups = map relVarToAtomList rvs

1394 mkRelationFromList attrs tups

1436 mkRelationFromList attrs tups

1395

1437

1438+

src/lib/ProjectM36/Server.hs+13−2

@@ -8,7 +8,11 @@ import ProjectM36.Server.Config (ServerConfig(..))

8import ProjectM36.FSType

10import Control.Monad.IO.Class (liftIO)

11+#if MIN_VERSION_network_transport_tcp(0,7,0)

12+import Network.Transport.TCP (createTransport, defaultTCPParameters, TCPAddr(..), TCPAddrInfo(..))

13+#else

11−import Network.Transport.TCP (createTransport, defaultTCPParameters)

14+import Network.Transport.TCP (createTransport, defaultTCPParameters)

15+#endif

12import Network.Transport (EndPointAddress(..), newEndPoint, address)

16import Network.Transport (EndPointAddress(..), newEndPoint, address)

13import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNode, initRemoteTable)

17import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNode, initRemoteTable)

14import Control.Distributed.Process.Extras.Time (Delay(..))

18import Control.Distributed.Process.Extras.Time (Delay(..))

@@ -117,7 +121,14 @@ launchServer daemonConfig mAddressMVar = do

117 Right conn -> do

121 Right conn -> do

118 let hostname = bindHost daemonConfig

122 let hostname = bindHost daemonConfig

119 port = bindPort daemonConfig

123 port = bindPort daemonConfig

120−#if MIN_VERSION_network_transport_tcp(0,6,0)

124+#if MIN_VERSION_network_transport_tcp(0,7,0)

125+ addrInfo = TCPAddrInfo {

126+ tcpBindHost = hostname,

127+ tcpBindPort = show port,

128+ tcpExternalAddress = \sn -> (hostname, sn)

129+ }

130+ etransport <- createTransport (Addressable addrInfo) defaultTCPParameters

131+#elif MIN_VERSION_network_transport_tcp(0,6,0)

121 etransport <- createTransport hostname (show port) (\nam -> (hostname, nam)) defaultTCPParameters

132 etransport <- createTransport hostname (show port) (\nam -> (hostname, nam)) defaultTCPParameters

122#else

133#else

123 etransport <- createTransport hostname (show port) defaultTCPParameters

134 etransport <- createTransport hostname (show port) defaultTCPParameters

src/lib/ProjectM36/StaticOptimizer.hs+80−68

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

3import ProjectM36.GraphRefRelationalExpr

4import ProjectM36.Relation

5import ProjectM36.RelationalExpression

6−import ProjectM36.TransGraphRelationalExpression as TGRE

6+import ProjectM36.TransGraphRelationalExpression as TGRE hiding (askGraph)

7import ProjectM36.Error

8import ProjectM36.Transaction

9import ProjectM36.NormalizeExpr

@@ -23,45 +23,56 @@ type StaticOptimizerEnv = RelationalExprEnv

23type 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 TransactionGraph (ExceptT RelationalError Identity) a

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

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

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

30optimizeAndEvalRelationalExpr env expr = do

31− let gfExpr = runProcessExprM tid graph (processRelationalExpr expr)

31+ let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr) -- references parent tid instead of context! options- I could add the context to the graph with a new transid or implement an evalRelationalExpr in RE.hs to use the context (which is what I had previously)

32− tid = re_currentTransId env

33 graph = re_graph env

32 graph = re_graph env

33+ ctx = re_context env

34− gfEnv = freshGraphRefRelationalExprEnv graph

34+ gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph

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

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

36 runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

38+askGraph :: GraphRefStaticOptimizerMonad TransactionGraph

39+askGraph = snd <$> ask

40+

41+askContext :: GraphRefStaticOptimizerMonad DatabaseContext

42+askContext = do

43+ mctx <- fst <$> ask

44+ case mctx of

45+ Nothing -> throwError NoUncommittedContextInEvalError

46+ Just ctx -> pure ctx

47+

48+askMaybeContext :: GraphRefStaticOptimizerMonad (Maybe DatabaseContext)

49+askMaybeContext = fst <$> ask

50+

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

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

39optimizeAndEvalDatabaseContextExpr optimize expr = do

52optimizeAndEvalDatabaseContextExpr optimize expr = do

40− tid <- dce_transId <$> ask

41 graph <- dce_graph <$> ask

53 graph <- dce_graph <$> ask

42− let gfExpr = runProcessExprM tid graph (processDatabaseContextExpr expr)

54+ let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr expr)

43 eOptExpr = if optimize then

55 eOptExpr = if optimize then

44− runGraphRefStaticOptimizerMonad graph (optimizeGraphRefDatabaseContextExpr gfExpr)

56+ runGraphRefStaticOptimizerMonad Nothing graph (optimizeGraphRefDatabaseContextExpr gfExpr)

45 else

57 else

46 pure gfExpr

58 pure gfExpr

47 case eOptExpr of

59 case eOptExpr of

48 Left err -> throwError err

60 Left err -> throwError err

49 Right optExpr -> evalGraphRefDatabaseContextExpr optExpr

61 Right optExpr -> evalGraphRefDatabaseContextExpr optExpr

63+

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

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

52optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do

65optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do

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

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

54− optExpr <- runGraphRefStaticOptimizerMonad graph (fullOptimizeGraphRefRelationalExpr gfExpr)

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

55− let gfEnv = freshGraphRefRelationalExprEnv graph

68+ let gfEnv = freshGraphRefRelationalExprEnv Nothing graph

56 runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

69 runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

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

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

59optimizeAndEvalDatabaseContextIOExpr expr = do

72optimizeAndEvalDatabaseContextIOExpr expr = do

60 env <- getDBCIORelationalExprEnv

73 env <- getDBCIORelationalExprEnv

61− let gfExpr = runProcessExprM tid graph (processDatabaseContextIOExpr expr)

74+ let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextIOExpr expr)

62 eOptExpr = runStaticOptimizerMonad env (optimizeDatabaseContextIOExpr gfExpr)

75 eOptExpr = runStaticOptimizerMonad env (optimizeDatabaseContextIOExpr gfExpr)

63− tid = re_currentTransId env

64− graph = re_graph env

65 case eOptExpr of

76 case eOptExpr of

66 Left err -> pure (Left err)

77 Left err -> pure (Left err)

67 Right optExpr ->

78 Right optExpr ->

@@ -71,12 +82,11 @@ optimizeAndEvalDatabaseContextIOExpr expr = do

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

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

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

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

74−runGraphRefStaticOptimizerMonad :: TransactionGraph -> GraphRefStaticOptimizerMonad a -> Either RelationalError a

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

75−runGraphRefStaticOptimizerMonad graph m = runIdentity (runExceptT (runReaderT m graph))

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

77−--RelationalExprEnv should not be necessary for graph ref re optimization!

78−optimizeGraphRefRelationalExpr' :: TransactionGraph -> GraphRefRelationalExpr -> Either RelationalError GraphRefRelationalExpr

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

79−optimizeGraphRefRelationalExpr' graph expr = runIdentity (runExceptT (runReaderT (optimizeGraphRefRelationalExpr expr) graph))

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

81fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

91fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

82fullOptimizeGraphRefRelationalExpr expr = do

92fullOptimizeGraphRefRelationalExpr expr = do

@@ -98,9 +108,9 @@ optimizeGraphRefRelationalExpr e@(RelationVariable _ _) = pure e

108

99--remove project of attributes which removes no attributes

109--remove project of attributes which removes no attributes

100optimizeGraphRefRelationalExpr (Project attrNameSet expr) = do

110optimizeGraphRefRelationalExpr (Project attrNameSet expr) = do

101− graph <- ask

111+ graph <- askGraph

102 let relType = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)

112 let relType = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)

103− gfEnv = freshGraphRefRelationalExprEnv graph

113+ gfEnv = freshGraphRefRelationalExprEnv Nothing graph

104 case relType of

114 case relType of

105 Left err -> throwError err

115 Left err -> throwError err

106 Right relType2

116 Right relType2

@@ -137,12 +147,13 @@ optimizeGraphRefRelationalExpr (Join exprA exprB) = do

137 pure (Join optExprA optExprB)

147 pure (Join optExprA optExprB)

138

148

139optimizeGraphRefRelationalExpr (Difference exprA exprB) = do

149optimizeGraphRefRelationalExpr (Difference exprA exprB) = do

140− graph <- ask

150+ graph <- askGraph

151+ context <- askMaybeContext

141 optExprA <- optimizeGraphRefRelationalExpr exprA

152 optExprA <- optimizeGraphRefRelationalExpr exprA

142 optExprB <- optimizeGraphRefRelationalExpr exprB

153 optExprB <- optimizeGraphRefRelationalExpr exprB

143 if optExprA == optExprB then do --A difference A == A where false

154 if optExprA == optExprB then do --A difference A == A where false

144 let eEmptyRel = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr optExprA)

155 let eEmptyRel = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr optExprA)

145− gfEnv = freshGraphRefRelationalExprEnv graph

156+ gfEnv = freshGraphRefRelationalExprEnv context graph

146 case eEmptyRel of

157 case eEmptyRel of

147 Left err -> throwError err

158 Left err -> throwError err

148 Right emptyRel -> pure (ExistingRelation emptyRel)

159 Right emptyRel -> pure (ExistingRelation emptyRel)

@@ -159,13 +170,13 @@ optimizeGraphRefRelationalExpr (Ungroup attrName expr) =

159

170

160--remove restriction of nothing

171--remove restriction of nothing

161optimizeGraphRefRelationalExpr (Restrict predicate expr) = do

172optimizeGraphRefRelationalExpr (Restrict predicate expr) = do

162− graph <- ask

173+ graph <- askGraph

163 optimizedPredicate <- applyStaticPredicateOptimization predicate

174 optimizedPredicate <- applyStaticPredicateOptimization predicate

164 case optimizedPredicate of

175 case optimizedPredicate of

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

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

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

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

167 let attributesRel = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)

178 let attributesRel = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)

168− gfEnv = freshGraphRefRelationalExprEnv graph

179+ gfEnv = freshGraphRefRelationalExprEnv Nothing graph

169 case attributesRel of

180 case attributesRel of

170 Left err -> throwError err

181 Left err -> throwError err

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

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

@@ -229,9 +240,9 @@ optimizeGraphRefDatabaseContextExpr c@(ExecuteDatabaseContextFunction _ _) = pur

229

240

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

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

231--for multiple expressions, we must evaluate

242--for multiple expressions, we must evaluate

232−optimizeGraphRefDatabaseContextExpr (MultipleExpr _) = do

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

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

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

234− unimplemented

245+-- unimplemented

235{- let processEmptyRelVars env = env { relationVariables = mkEmptyRelVars (relationVariables env) }

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

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

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

237

248

@@ -331,56 +342,57 @@ isStaticAtomExpr RelationAtomExpr{} = False

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

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

332applyStaticJoinElimination :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

343applyStaticJoinElimination :: GraphRefRelationalExpr -> GraphRefStaticOptimizerMonad GraphRefRelationalExpr

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

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

334− graph <- ask

345+ graph <- askGraph

335 case inSameTransaction exprA exprB of

346 case inSameTransaction exprA exprB of

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

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

337− Nothing -> pure expr

348+ Nothing -> pure expr

338− Just commonTransId -> do

349+ Just marker -> do

350+ commonContext <- case marker of

351+ UncommittedContextMarker -> askContext

352+ TransactionMarker tid -> concreteDatabaseContext <$> lift (except (transactionForId tid graph))

339− let typeForExpr e = lift $ except $ runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr e)

353+ let typeForExpr e = lift $ except $ runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr e)

340− gfEnv = freshGraphRefRelationalExprEnv graph

354+ gfEnv = freshGraphRefRelationalExprEnv (Just commonContext) graph

355+

341− projType <- typeForExpr expr

356+ projType <- typeForExpr expr

342− typeA <- typeForExpr exprA

357+ typeA <- typeForExpr exprA

343− typeB <- typeForExpr exprB

358+ typeB <- typeForExpr exprB

344− let matchesProjectionAttributes

359+ let matchesProjectionAttributes

345− | attrNames projType `S.isSubsetOf` attrNames typeA =

360+ | attrNames projType `S.isSubsetOf` attrNames typeA =

346− Just ((exprA, typeA), (exprB, typeB))

361+ Just ((exprA, typeA), (exprB, typeB))

347− | attrNames projType `S.isSubsetOf` attrNames typeB =

362+ | attrNames projType `S.isSubsetOf` attrNames typeB =

348− Just ((exprB, typeB), (exprA, typeA))

363+ Just ((exprB, typeB), (exprA, typeA))

349− | otherwise =

364+ | otherwise =

350− Nothing

365+ Nothing

351− attrNames = A.attributeNameSet . attributes

366+ attrNames = A.attributeNameSet . attributes

352− case matchesProjectionAttributes of

367+ case matchesProjectionAttributes of

353− Nothing -> -- this optimization does not apply

368+ Nothing -> -- this optimization does not apply

354− pure expr

369+ pure expr

355− Just ((joinedExpr, joinedType), (unjoinedExpr, _)) -> do

370+ Just ((joinedExpr, joinedType), (unjoinedExpr, _)) -> do

356 --lookup transaction

371 --lookup transaction

357− trans <- lift $ except (transactionForId commonTransId graph)

358 --scan inclusion dependencies for a foreign key relationship

372 --scan inclusion dependencies for a foreign key relationship

359− let incDeps = inclusionDependencies commonContext

373+ let incDeps = inclusionDependencies commonContext

360− commonContext = concreteDatabaseContext trans

361− reEnv = mkRelationalExprEnv commonContext commonTransId graph

362− fkConstraint = foldM isFkConstraint False incDeps

374+ fkConstraint = foldM isFkConstraint False incDeps

363 --search for matching fk constraint

375 --search for matching fk constraint

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

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

365− let gfSubAttrNames = processM (processAttributeNames subAttrNames)

377+ let gfSubAttrNames = processM (processAttributeNames subAttrNames)

366− gfSubRv = processM (processRelationalExpr subrv)

378+ gfSubRv = processM (processRelationalExpr subrv)

367− gfSuperRv = processM (processRelationalExpr superrv)

379+ gfSuperRv = processM (processRelationalExpr superrv)

368− processM = runProcessExprM commonTransId graph

380+ processM = runProcessExprM marker

369− case runGraphRefRelationalExprM gfEnv (evalGraphRefAttributeNames gfSubAttrNames expr) of

381+ case runGraphRefRelationalExprM gfEnv (evalGraphRefAttributeNames gfSubAttrNames expr) of

370− Left _ -> pure acc

382+ Left _ -> pure acc

371− Right subAttrNameSet ->

383+ Right subAttrNameSet ->

372− pure (acc || (joinedExpr == gfSubRv &&

384+ pure (acc || (joinedExpr == gfSubRv &&

373 unjoinedExpr == gfSuperRv &&

385 unjoinedExpr == gfSuperRv &&

374 -- the fk attribute is one of the projection attributes

386 -- the fk attribute is one of the projection attributes

375 A.attributeNamesContained subAttrNameSet (A.attributeNameSet (attributes joinedType))

387 A.attributeNamesContained subAttrNameSet (A.attributeNameSet (attributes joinedType))

376 ))

388 ))

377− isFkConstraint acc _ = pure acc

389+ isFkConstraint acc _ = pure acc

378− case fkConstraint of

390+ case fkConstraint of

379− Right True -> --join elimination optimization applies

391+ Right True -> --join elimination optimization applies

380− optimizeGraphRefRelationalExpr (Project attrNameSet joinedExpr)

392+ optimizeGraphRefRelationalExpr (Project attrNameSet joinedExpr)

381− Right False -> --join elimination optimization does not apply

393+ Right False -> --join elimination optimization does not apply

382− pure expr

394+ pure expr

383− Left err -> throwError err

395+ Left err -> throwError err

384

396

385applyStaticJoinElimination expr = pure expr

397applyStaticJoinElimination expr = pure expr

386

398

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

@@ -58,8 +58,8 @@ liftE = lift . except

58askGraph :: TransGraphEvalMonad TransactionGraph

59askGraph = tge_graph <$> ask

61−findTransId :: TransactionIdLookup -> TransGraphEvalMonad TransactionId

61+findTransId :: TransactionIdLookup -> TransGraphEvalMonad GraphRefTransactionMarker

62−findTransId tlook = transactionId <$> findTrans tlook

62+findTransId tlook = TransactionMarker . transactionId <$> findTrans tlook

64findTrans :: TransactionIdLookup -> TransGraphEvalMonad Transaction

65findTrans tlook = do

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

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

19 case eSessionId of

20 Left err -> error (show err)

21 Right sessionId -> do

22− mapM_ (\(rvName,rvRel) -> executeDatabaseContextExpr sessionId conn (Assign rvName (Base.ExistingRelation rvRel))) (M.toList (Base.relationVariables dateExamples))

22+ executeDatabaseContextExpr sessionId conn (databaseContextAsDatabaseContextExpr dateExamples

23− mapM_ (\(idName,incDep) -> executeDatabaseContextExpr sessionId conn (AddInclusionDependency idName incDep)) (M.toList incDeps)

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

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

25 commit sessionId conn >>= eitherFail

24 commit sessionId conn >>= eitherFail

26 pure (sessionId, conn)

25 pure (sessionId, conn)