20a004d · project-m36 · git.iko.soy

git.iko.soy/project-m36

compilation checkpoint- tutd, server components in place

still need to merge relationalexpr/transgraphrelationalexpr add support for git-style graph navigation from head ~^

commit20a004daf405d776bc1a1a10b19df22a4c111f4a authorAgentM <agentm@themactionfaction.com> dateTue 6 Sep 2016, 15:38 (10 years ago) parent7eca51f

11 files changed+340−21

compare with master

unifiedsplit

src/bin/TutorialD/Interpreter.hs+8−3 src/bin/TutorialD/Interpreter/Base.hs+9−1 src/bin/TutorialD/Interpreter/RelationalExpr.hs+4−4 src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+277 src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs−7 src/lib/ProjectM36/Client.hs+15−1 src/lib/ProjectM36/Server.hs+1 src/lib/ProjectM36/Server/EntryPoints.hs+5 src/lib/ProjectM36/Server/RemoteCallTypes.hs+3 src/lib/ProjectM36/TransGraphRelationalExpression.hs+13 src/lib/ProjectM36/TransactionGraph.hs+5−5

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

@@ -6,6 +6,7 @@ import TutorialD.Interpreter.DatabaseContextExpr

66import TutorialD.Interpreter.TransactionGraphOperator

77import TutorialD.Interpreter.InformationOperator

88import TutorialD.Interpreter.DatabaseContextIOOperator

9+import TutorialD.Interpreter.TransGraphRelationalOperator

910

1011import TutorialD.Interpreter.Import.CSV

1112import TutorialD.Interpreter.Import.TutorialD

@@ -44,7 +45,8 @@ data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |

4445 ImportRelVarOp RelVarDataImportOperator |

4546 ImportDBContextOp DatabaseContextDataImportOperator |

4647 ImportBasicExampleOp ImportBasicExampleOperator |

47− RelVarExportOp RelVarDataExportOperator

48+ RelVarExportOp RelVarDataExportOperator |

49+ TransGraphRelationalOp TransGraphRelationalOperator

4850

4951interpreterParserP :: Parser ParsedOperation

5052interpreterParserP = safeInterpreterParserP <|>

@@ -60,7 +62,8 @@ safeInterpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <

6062 liftM GraphOp (transactionGraphOpP <* eof) <|>

6163 liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>

6264 liftM DatabaseContextExprOp (databaseExprOpP <* eof) <|>

63− liftM ImportBasicExampleOp (importBasicExampleOperatorP <* eof)

65+ liftM ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|>

66+ liftM TransGraphRelationalOp (transGraphRelationalOpP <* eof)

6467

6568

6669promptText :: Maybe HeadName -> StringType

@@ -119,7 +122,7 @@ evalTutorialD sessionId conn safe expr = case expr of

119122 else do

120123 -- collect attributes from relvar name

121124 -- is there a race condition here? The attributes of the relvar may have since changed, no?

122− eImportType <- C.typeForRelationalExpr sessionId conn (RelationVariable relVarName)

125+ eImportType <- C.typeForRelationalExpr sessionId conn (RelationVariable relVarName ())

123126 case eImportType of

124127 Left err -> barf err

125128 Right importType -> do

@@ -161,6 +164,8 @@ evalTutorialD sessionId conn safe expr = case expr of

161164 (ImportBasicExampleOp execOp) -> do

162165 let dbcontextexpr = evalImportBasicExampleOperator execOp

163166 evalTutorialD sessionId conn safe (DatabaseContextExprOp dbcontextexpr)

167+ (TransGraphRelationalOp execOp) -> do

168+ evalTransGraphRelationalOp sessionId conn execOp

164169 where

165170 needsSafe = safe == SafeEvaluation

166171 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."

src/bin/TutorialD/Interpreter/Base.hs+9−1

@@ -15,6 +15,7 @@ import ProjectM36.Relation.Show.Term

1515import GHC.Generics

1616import Data.Monoid

1717import Control.Monad (void)

18+import qualified Data.UUID as U

1819

1920displayOpResult :: TutorialDOperatorResult -> IO ()

2021displayOpResult QuitResult = return ()

@@ -122,4 +123,11 @@ normalQuotedString :: Parser Text

122123normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)

123124

124125quotedString :: Parser Text

125−quotedString = try tripleQuotedString <|> normalQuotedString

126+quotedString = try tripleQuotedString <|> normalQuotedString

127+

128+uuidP :: Parser U.UUID

129+uuidP = do

130+ uuidStr <- count' 28 (28 + 4) (hexDigitChar <|> char '-') -- min 28 with no dashes, maximum 4 dashes

131+ case U.fromString uuidStr of

132+ Nothing -> fail "Invalid uuid string"

133+ Just uuid -> return uuid

src/bin/TutorialD/Interpreter/RelationalExpr.hs+4−4

@@ -36,7 +36,7 @@ attributeAndTypeNameP = do

3636 attrName <- identifier

3737 --convert type name into type

3838 typeCons <- typeConstructorP

39− return $ AttributeAndTypeNameExpr attrName typeCons

39+ return $ AttributeAndTypeNameExpr attrName typeCons ()

4040

4141--abstract data type parser- in this context, the type constructor must not include any type arguments

4242--Either Text Int

@@ -131,7 +131,7 @@ relExprP :: Parser RelationalExpr

131131relExprP = makeExprParser relTerm relOperators

132132

133133relVarP :: Parser RelationalExpr

134−relVarP = liftA RelationVariable identifier

134+relVarP = RelationVariable <$> identifier <*> pure ()

135135

136136relTerm :: Parser RelationalExpr

137137relTerm = parens relExprP

@@ -206,7 +206,7 @@ constructedAtomExprP :: Bool -> Parser AtomExpr

206206constructedAtomExprP consume = do

207207 dConsName <- capitalizedIdentifier

208208 dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure []

209− pure $ ConstructedAtomExpr dConsName dConsArgs

209+ pure $ ConstructedAtomExpr dConsName dConsArgs ()

210210

211211-- used only for primitive type parsing ?

212212atomP :: Parser Atom

@@ -219,7 +219,7 @@ functionAtomExprP :: Parser AtomExpr

219219functionAtomExprP = do

220220 funcName <- identifier

221221 argList <- parens (sepBy atomExprP comma)

222− return $ FunctionAtomExpr funcName argList

222+ return $ FunctionAtomExpr funcName argList ()

223223

224224relationalAtomExprP :: Parser AtomExpr

225225relationalAtomExprP = RelationAtomExpr <$> relExprP

src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hsnew file+277

@@ -0,0 +1,277 @@

1+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

2+module TutorialD.Interpreter.TransGraphRelationalOperator where

3+import ProjectM36.Base

4+import ProjectM36.TransGraphRelationalExpression

5+import ProjectM36.TransactionGraph

6+import ProjectM36.MiscUtils

7+import qualified ProjectM36.Client as C

9+import TutorialD.Interpreter.Base

10+import TutorialD.Interpreter.Types

11+

12+import Text.Megaparsec

13+import Text.Megaparsec.Text

14+import Text.Megaparsec.Expr

15+

16+import Control.Applicative

17+import qualified Data.Set as S

18+import qualified Data.Map as M

19+import qualified Data.Text as T

20+import Data.List (sort)

21+

22+class RelationalMarkerExpr a where

23+ parseMarkerP :: Parser a

24+

25+instance RelationalMarkerExpr () where

26+ parseMarkerP = pure ()

27+

28+instance RelationalMarkerExpr TransactionIdLookup where

29+ parseMarkerP = string "@" *> transactionIdLookupP

30+

31+data TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr

32+

33+transactionIdLookupP :: Parser TransactionIdLookup

34+transactionIdLookupP = (TransactionIdLookup <$> uuidP) <|>

35+ (TransactionIdHeadNameLookup <$> identifier)

36+

37+transGraphRelationalOpP :: Parser TransGraphRelationalOperator

38+transGraphRelationalOpP = showTransGraphRelationalOpP

39+

40+showTransGraphRelationalOpP :: Parser TransGraphRelationalOperator

41+showTransGraphRelationalOpP = do

42+ reservedOp ":showtransgraphexpr"

43+ ShowTransGraphRelation <$> relExprP

44+

45+--used in projection

46+attributeListP :: Parser AttributeNames

47+attributeListP = do

48+ but <- try (string "all but " <* spaceConsumer) <|> string ""

49+ let constructor = if but == "" then AttributeNames else InvertedAttributeNames

50+ attrs <- sepBy identifier comma

51+ pure $ constructor (S.fromList attrs)

52+

53+makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

54+makeRelationP = do

55+ reserved "relation"

56+ attrExprs <- try (liftA Just makeAttributeExprsP) <|> pure Nothing

57+ tupleExprs <- braces (sepBy tupleExprP comma) <|> pure []

58+ pure $ MakeRelationFromExprs attrExprs tupleExprs

59+

60+--used in relation creation

61+makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a]

62+makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma)

63+

64+attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a)

65+attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstructorP <*> parseMarkerP

66+

67+--abstract data type parser- in this context, the type constructor must not include any type arguments

68+--Either Text Int

69+adTypeConstructorP :: Parser TypeConstructor

70+adTypeConstructorP = do

71+ tConsName <- capitalizedIdentifier

72+ tConsArgs <- many typeConstructorArgP

73+ pure $ ADTypeConstructor tConsName tConsArgs

74+

75+tupleExprP :: RelationalMarkerExpr a => Parser (TupleExprBase a)

76+tupleExprP = do

77+ reservedOp "tuple"

78+ attrAssocs <- braces (sepBy tupleAtomExprP comma)

79+ --detect duplicate attribute names

80+ let dupAttrNames = dupes (sort (map fst attrAssocs))

81+ if length dupAttrNames /= 0 then

82+ fail ("Attribute names duplicated: " ++ show dupAttrNames)

83+ else

84+ pure (TupleExpr (M.fromList attrAssocs))

85+

86+tupleAtomExprP :: RelationalMarkerExpr a => Parser (AttributeName, AtomExprBase a)

87+tupleAtomExprP = do

88+ attributeName <- identifier

89+ atomExpr <- atomExprP

90+ pure $ (attributeName, atomExpr)

91+

92+projectP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

93+projectP = do

94+ attrs <- braces attributeListP

95+ pure $ Project attrs

96+

97+renameClauseP :: Parser (T.Text, T.Text)

98+renameClauseP = do

99+ oldAttr <- identifier

100+ reservedOp "as"

101+ newAttr <- identifier

102+ pure $ (oldAttr, newAttr)

103+

104+renameP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

105+renameP = do

106+ reservedOp "rename"

107+ (oldAttr, newAttr) <- braces renameClauseP

108+ return $ Rename oldAttr newAttr

109+

110+whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

111+whereClauseP = reservedOp "where" *> (Restrict <$> restrictionPredicateP)

112+

113+groupClauseP :: Parser (AttributeNames, T.Text)

114+groupClauseP = do

115+ attrs <- braces attributeListP

116+ reservedOp "as"

117+ newAttrName <- identifier

118+ return $ (attrs, newAttrName)

119+

120+groupP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

121+groupP = do

122+ reservedOp "group"

123+ (groupAttrList, groupAttrName) <- parens groupClauseP

124+ pure $ Group groupAttrList groupAttrName

125+

126+--in "Time and Relational Theory" (2014), Date's Tutorial D grammar for ungroup takes one attribute, while in previous books, it take multiple arguments. Let us assume that nested ungroups are the same as multiple attributes.

127+ungroupP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

128+ungroupP = do

129+ reservedOp "ungroup"

130+ rvaAttrName <- identifier

131+ pure $ Ungroup rvaAttrName

132+

133+extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

134+extendP = do

135+ reservedOp ":"

136+ tupleExpr <- braces extendTupleExpressionP

137+ return $ Extend tupleExpr

138+

139+relOperators :: RelationalMarkerExpr a => [[Operator Parser (RelationalExprBase a)]]

140+relOperators = [

141+ [Postfix projectP],

142+ [Postfix renameP],

143+ [Postfix whereClauseP],

144+ [Postfix groupP],

145+ [Postfix ungroupP],

146+ [InfixL (reservedOp "join" >> return Join)],

147+ [InfixL (reservedOp "union" >> return Union)],

148+ [InfixL (reservedOp "minus" >> return Difference)],

149+ [InfixN (reservedOp "=" >> return Equals)],

150+ [Postfix extendP]

151+ ]

152+

153+relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

154+relExprP = makeExprParser relTerm relOperators

155+

156+relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

157+relVarP = RelationVariable <$> identifier <*> parseMarkerP

158+

159+relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

160+relTerm = parens relExprP

161+ <|> makeRelationP

162+ <|> relVarP

163+

164+restrictionPredicateP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

165+restrictionPredicateP = makeExprParser predicateTerm predicateOperators

166+ where

167+ predicateOperators = [

168+ [Prefix (reservedOp "not" >> return NotPredicate)],

169+ [InfixL (reservedOp "and" >> return AndPredicate)],

170+ [InfixL (reservedOp "or" >> return OrPredicate)]

171+ ]

172+ predicateTerm = parens restrictionPredicateP

173+ <|> try restrictionAtomExprP

174+ <|> try restrictionAttributeEqualityP

175+ <|> try relationalBooleanExprP

176+

177+

178+relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

179+relationalBooleanExprP = do

180+ relexpr <- relExprP

181+ return $ RelationalExprPredicate relexpr

182+

183+restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

184+restrictionAttributeEqualityP = do

185+ attributeName <- identifier

186+ reservedOp "="

187+ atomexpr <- atomExprP

188+ return $ AttributeEqualityPredicate attributeName atomexpr

189+

190+restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"

191+restrictionAtomExprP = do

192+ _ <- char '^' -- not ideal, but allows me to continue to use a context-free grammar

193+ AtomExprPredicate <$> atomExprP

194+

195+multiTupleExpressionP :: RelationalMarkerExpr a => Parser [ExtendTupleExprBase a]

196+multiTupleExpressionP = sepBy extendTupleExpressionP comma

197+

198+extendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)

199+extendTupleExpressionP = attributeExtendTupleExpressionP

200+

201+attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)

202+attributeExtendTupleExpressionP = do

203+ newAttr <- identifier

204+ reservedOp ":="

205+ atom <- atomExprP

206+ return $ AttributeExtendTupleExpr newAttr atom

207+

208+atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

209+atomExprP = consumeAtomExprP True

210+

211+consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)

212+consumeAtomExprP consume = try functionAtomExprP <|>

213+ try (parens (constructedAtomExprP True)) <|>

214+ constructedAtomExprP consume <|>

215+ attributeAtomExprP <|>

216+ nakedAtomExprP <|>

217+ relationalAtomExprP

218+

219+attributeAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

220+attributeAtomExprP = do

221+ _ <- string "@"

222+ attrName <- identifier

223+ return $ AttributeAtomExpr attrName

224+

225+nakedAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

226+nakedAtomExprP = NakedAtomExpr <$> atomP

227+

228+constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)

229+constructedAtomExprP consume = do

230+ dConsName <- capitalizedIdentifier

231+ dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure []

232+ marker <- parseMarkerP

233+ pure $ ConstructedAtomExpr dConsName dConsArgs marker

234+

235+-- used only for primitive type parsing ?

236+atomP :: Parser Atom

237+atomP = stringAtomP <|>

238+ doubleAtomP <|>

239+ intAtomP <|>

240+ boolAtomP

241+

242+functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

243+functionAtomExprP = do

244+ funcName <- identifier

245+ argList <- parens (sepBy atomExprP comma)

246+ marker <- parseMarkerP

247+ return $ FunctionAtomExpr funcName argList marker

248+

249+relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

250+relationalAtomExprP = RelationAtomExpr <$> relExprP

251+

252+stringAtomP :: Parser Atom

253+stringAtomP = liftA TextAtom quotedString

254+

255+doubleAtomP :: Parser Atom

256+doubleAtomP = DoubleAtom <$> (try float)

257+

258+intAtomP :: Parser Atom

259+intAtomP = do

260+ i <- integer

261+ return $ IntAtom (fromIntegral i)

262+

263+boolAtomP :: Parser Atom

264+boolAtomP = do

265+ val <- char 't' <|> char 'f'

266+ return $ BoolAtom (val == 't')

267+

268+relationAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

269+relationAtomExprP = RelationAtomExpr <$> makeRelationP

270+

271+evalTransGraphRelationalOp :: C.SessionId -> C.Connection -> TransGraphRelationalOperator -> IO TutorialDOperatorResult

272+evalTransGraphRelationalOp sessionId conn (ShowTransGraphRelation expr) = do

273+ res <- C.executeTransGraphRelationalExpr sessionId conn expr

274+ case res of

275+ Left err -> pure $ DisplayErrorResult $ T.pack (show err)

276+ Right rel -> pure $ DisplayRelationResult rel

277+

src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs−7

@@ -3,7 +3,6 @@ module TutorialD.Interpreter.TransactionGraphOperator where

33import TutorialD.Interpreter.Base

44import Text.Megaparsec.Text

55import Text.Megaparsec

6−import qualified Data.UUID as U

76import ProjectM36.TransactionGraph

87import ProjectM36.Client

98import ProjectM36.Error

@@ -73,12 +72,6 @@ transactionGraphOpP = do

7372roTransactionGraphOpP :: Parser ROTransactionGraphOperator

7473roTransactionGraphOpP = showGraphP

7574

76−uuidP :: Parser U.UUID

77−uuidP = do

78− uuidStr <- many (alphaNumChar <|> char '-')

79− case U.fromString uuidStr of

80− Nothing -> fail "Invalid uuid string"

81− Just uuid -> return uuid

8275

8376

8477{-

src/lib/ProjectM36/Client.hs+15−1

@@ -12,6 +12,7 @@ module ProjectM36.Client

1212 executeDatabaseContextExpr,

1313 executeDatabaseContextIOExpr,

1414 executeGraphExpr,

15+ executeTransGraphRelationalExpr,

1516 commit,

1617 rollback,

1718 typeForRelationalExpr,

@@ -40,6 +41,7 @@ module ProjectM36.Client

4041 addClientNode,

4142 RelationCardinality(..),

4243 TransactionGraphOperator(..),

44+ TransGraphRelationalExpr(..),

4345 NodeId(..),

4446 Atom(..),

4547 Session,

@@ -61,6 +63,7 @@ import ProjectM36.DatabaseContext (basicDatabaseContext)

6163import ProjectM36.TransactionGraph

6264import ProjectM36.TransactionGraph.Persist

6365import ProjectM36.Attribute hiding (atomTypes)

66+import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr)

6467import ProjectM36.Persist (DiskSync(..))

6568import ProjectM36.Notifications

6669import ProjectM36.Server.RemoteCallTypes

@@ -351,7 +354,7 @@ executeRelationalExpr sessionId (InProcessConnection _ _ sessions _ _) expr = ex

351354 Left err -> pure (Left err)

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

353356executeRelationalExpr sessionId conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)

354−

357+

355358-- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.

356359executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Maybe RelationalError)

357360executeDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _ _) expr = excMaybe $ atomically $ do

@@ -453,6 +456,17 @@ commitSTM_ freshUUID sessionId sessions graph = do

453456 Right _ -> Nothing

454457-}

455458

459+-- | A trans-graph expression is a relational query executed against the entirety of a transaction graph.

460+executeTransGraphRelationalExpr :: SessionId -> Connection -> TransGraphRelationalExpr -> IO (Either RelationalError Relation)

461+executeTransGraphRelationalExpr sessionId conn@(InProcessConnection _ _ sessions graphTvar _) tgraphExpr = excEither . atomically $ do

462+ graph <- readTVar graphTvar

463+ case evalTransGraphRelationalExpr tgraphExpr graph of

464+ Left err -> pure (Left err)

465+ Right relExpr -> case evalState (RE.evalRelationalExpr relExpr) RE.emptyDatabaseContext of

466+ Left err -> pure (Left err)

467+ Right rel -> pure (force (Right rel))

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

469+

456470-- | After modifying a session, 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated.

457471commit :: SessionId -> Connection -> IO (Maybe RelationalError)

458472commit sessionId conn@(InProcessConnection _ _ _ _ _) = executeGraphExpr sessionId conn Commit

src/lib/ProjectM36/Server.hs+1

@@ -25,6 +25,7 @@ serverDefinition = defaultProcess {

2525 handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr sessionId conn expr),

2626 handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr sessionId conn expr),

2727 handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr sessionId conn expr),

28+ handleCall (\conn (ExecuteTransGraphRelationalExpr sessionId expr) -> handleExecuteTransGraphRelationalExpr sessionId conn expr),

2829 handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr sessionId conn expr),

2930 handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies sessionId conn),

3031 handleCall (\conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> handleRetrievePlanForDatabaseContextExpr sessionId conn dbExpr),

src/lib/ProjectM36/Server/EntryPoints.hs+5

@@ -38,6 +38,11 @@ handleExecuteGraphExpr sessionId conn graphExpr = do

3838 ret <- liftIO $ executeGraphExpr sessionId conn graphExpr

3939 reply ret conn

4040

41+handleExecuteTransGraphRelationalExpr :: SessionId -> Connection -> TransGraphRelationalExpr -> Process (ProcessReply (Either RelationalError Relation) Connection)

42+handleExecuteTransGraphRelationalExpr sessionId conn graphExpr = do

43+ ret <- liftIO $ executeTransGraphRelationalExpr sessionId conn graphExpr

44+ reply ret conn

45+

4146handleExecuteTypeForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> Process (ProcessReply (Either RelationalError Relation) Connection)

4247handleExecuteTypeForRelationalExpr sessionId conn relExpr = do

4348 ret <- liftIO $ typeForRelationalExpr sessionId conn relExpr

src/lib/ProjectM36/Server/RemoteCallTypes.hs+3

@@ -2,6 +2,7 @@

22module ProjectM36.Server.RemoteCallTypes where

33import ProjectM36.Base

44import ProjectM36.TransactionGraph

5+import ProjectM36.TransGraphRelationalExpression

56import ProjectM36.Session

67import GHC.Generics

78import Data.Binary

@@ -21,6 +22,8 @@ data ExecuteDatabaseContextIOExpr = ExecuteDatabaseContextIOExpr SessionId Datab

2122 deriving (Binary, Generic)

2223data ExecuteGraphExpr = ExecuteGraphExpr SessionId TransactionGraphOperator

2324 deriving (Binary, Generic)

25+data ExecuteTransGraphRelationalExpr = ExecuteTransGraphRelationalExpr SessionId TransGraphRelationalExpr

26+ deriving (Binary, Generic)

2427data ExecuteHeadName = ExecuteHeadName SessionId

2528 deriving (Binary, Generic)

2629data ExecuteTypeForRelationalExpr = ExecuteTypeForRelationalExpr SessionId RelationalExpr

src/lib/ProjectM36/TransGraphRelationalExpression.hs+13

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

1+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

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

13--really, a better name for this module could be "TransTransactionGraphRelationalExpr", but that name is too long

24module ProjectM36.TransGraphRelationalExpression where

35import ProjectM36.Base

@@ -8,18 +10,29 @@ import Control.Monad.State

810import ProjectM36.Tuple

911import ProjectM36.AtomType

1012import qualified Data.Map as M

13+import Data.Binary

1114

1215-- | The TransGraphRelationalExpression is equivalent to a relational expression except that relation variables can reference points in the transaction graph (at previous points in time).

1316type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup

1417

18+instance Binary TransGraphRelationalExpr

19+

1520type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup

1621

22+instance Binary TransGraphExtendTupleExpr

23+

1724type TransGraphTupleExpr = TupleExprBase TransactionIdLookup

1825

26+instance Binary TransGraphTupleExpr

27+

1928type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup

2029

30+instance Binary TransGraphRestrictionPredicateExpr

31+

2132type TransGraphAtomExpr = AtomExprBase TransactionIdLookup

2233

34+instance Binary TransGraphAtomExpr

35+

2336type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup

2437

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

src/lib/ProjectM36/TransactionGraph.hs+5−5

@@ -22,6 +22,7 @@ import Data.Either (lefts, rights, isRight)

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

2323data TransactionIdLookup = TransactionIdLookup TransactionId |

2424 TransactionIdHeadNameLookup HeadName

25+ deriving (Show, Eq, Binary, Generic)

2526

2627-- topic~3^2

2728data TransactionIdHeadBacktrack = TransactionIdHeadParentBackTrack Int | -- git ~: walk back n parents, arbitrarily choosing a parent when a choice must be made

@@ -419,9 +420,8 @@ createUnionMergeTransaction newId strategy graph (t1,t2) = do

419420 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)

420421 pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) (DatabaseContext incDeps relVars atomFuncs notifs types))

421422

422−-- |

423−evalTransactionIdLookup :: TransactionGraph -> TransactionIdLookup -> Either RelationalError TransactionId

424−evalTransactionIdLookup = undefined

425−

426423lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

427−lookupTransaction = undefined

424+lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

425+lookupTransaction graph (TransactionIdHeadNameLookup headName) = case transactionForHead headName graph of

426+ Just t -> Right t

427+ Nothing -> Left (NoSuchHeadNameError headName)