66ee004 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP

66ee004AgentM7 years ago

src/lib/ProjectM36/Base.hs+28−5

compare with master

unifiedsplit

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

192 --in Tutorial D, relational variables pick up the type of the first relation assigned to them

193 --relational variables should also be able to be explicitly-typed like in Haskell

194 --- | Reference a relation variable by its name.

195− RelationVariable RelVarName a |

195+ RelationVariable RelVarName a |

196 --- | Create a projection over attribute names. (Note that the 'AttributeNames' structure allows for the names to be inverted.)

197 Project (AttributeNamesBase a) (RelationalExprBase a) |

198 --- | Create a union of two relational expressions. The expressions should have identical attributes.

@@ -263,7 +263,10 @@ data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructo

263 deriving (Show, Generic, Binary, Eq, NFData)

264

265type InclusionDependencies = M.Map IncDepName InclusionDependency

266−type RelationVariables = M.Map RelVarName RelationVariable --change to RelationalExprBase TransactionId

266+type RelationVariables = M.Map RelVarName GraphRefRelationalExpr

267+

268+-- a fundamental relational expr to which other relational expressions compile

269+type GraphRefRelationalExpr = RelationalExprBase TransactionId

267

270

268type SchemaName = StringType

271type SchemaName = StringType

269

272

@@ -352,6 +355,8 @@ data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor]

352

355

353type RestrictionPredicateExpr = RestrictionPredicateExprBase ()

356type RestrictionPredicateExpr = RestrictionPredicateExprBase ()

354

357

358+type GraphRefRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionId

359+

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

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

356data RestrictionPredicateExprBase a =

361data RestrictionPredicateExprBase a =

357 TruePredicate |

362 TruePredicate |

@@ -418,6 +423,8 @@ instance Ord Transaction where

418

423

419type AtomExpr = AtomExprBase ()

424type AtomExpr = AtomExprBase ()

420

425

426+type GraphRefAtomExpr = AtomExprBase TransactionId

427+

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

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

422data AtomExprBase a = AttributeAtomExpr AttributeName |

429data AtomExprBase a = AttributeAtomExpr AttributeName |

423 NakedAtomExpr Atom |

430 NakedAtomExpr Atom |

@@ -435,7 +442,7 @@ data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBas

435type ExtendTupleExpr = ExtendTupleExprBase ()

442type ExtendTupleExpr = ExtendTupleExprBase ()

436

443

437instance Binary ExtendTupleExpr

444instance Binary ExtendTupleExpr

438−

445+

439--enumerates the list of functions available to be run as part of tuple expressions

446--enumerates the list of functions available to be run as part of tuple expressions

440type AtomFunctions = HS.HashSet AtomFunction

447type AtomFunctions = HS.HashSet AtomFunction

441

448

@@ -502,8 +509,8 @@ data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructo

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

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

503 deriving (Eq, Show, Generic, NFData)

510 deriving (Eq, Show, Generic, NFData)

504

511

505−instance Binary TupleExpr

512+instance Binary TupleExpr

506−

513+

507type TupleExpr = TupleExprBase ()

514type TupleExpr = TupleExprBase ()

508

515

509data MergeStrategy =

516data MergeStrategy =

@@ -577,3 +584,19 @@ atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList att

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

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

578atomTypeVars (TypeVariableType nam) = S.singleton nam

585atomTypeVars (TypeVariableType nam) = S.singleton nam

579

586

587+unimplemented :: a

588+unimplemented = undefined

589+

590+--for serializing GraphRefRelationalExpr as part of transaction serialization

591+instance Binary (TupleExprBase TransactionId)

592+

593+instance Binary GraphRefRelationalExpr

594+

595+instance Binary (AtomExprBase TransactionId)

596+

597+instance Binary (AttributeNamesBase TransactionId)

598+

599+instance Binary (RestrictionPredicateExprBase TransactionId)

600+

601+instance Binary (ExtendTupleExprBase TransactionId)

602+

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

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

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

19databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr

20−databaseContextAsDatabaseContextExpr context = MultipleExpr $ relVarsExprs ++ incDepsExprs ++ funcsExprs

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

21 where

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

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

23 incDepsExprs :: [DatabaseContextExpr]

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

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

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

27basicDatabaseContext :: DatabaseContext

28basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

29− relationVariables = M.fromList [("true", relationTrue),

29+ relationVariables = M.fromList [("true", ExistingRelation relationTrue),

30− ("false", relationFalse)],

30+ ("false", ExistingRelation relationFalse)],

31 atomFunctions = basicAtomFunctions,

32 dbcFunctions = basicDatabaseContextFunctions,

33 notifications = M.empty,

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

@@ -16,9 +16,9 @@ dateExamples = empty { inclusionDependencies = dateIncDeps,

16 atomFunctions = basicAtomFunctions,

17 typeConstructorMapping = basicTypeConstructorMapping }

18 where -- these must be lower case now that data constructors are in play

19− dateRelVars = M.fromList [("s", suppliers),

19+ dateRelVars = M.fromList [("s", ExistingRelation suppliers),

20− ("p", products),

20+ ("p", ExistingRelation products),

21− ("sp", supplierProducts)]

21+ ("sp", ExistingRelation supplierProducts)]

22 suppliers = suppliersRel

23 products = productsRel

24 supplierProducts = supplierProductsRel

src/lib/ProjectM36/RelationalExpression.hs+192−142

@@ -4,6 +4,7 @@ import ProjectM36.Relation

4import ProjectM36.Tuple

5import ProjectM36.TupleSet

6import ProjectM36.Base

7+import qualified Data.UUID as U

7import ProjectM36.Error

8import ProjectM36.Error

8import ProjectM36.AtomType

9import ProjectM36.AtomType

9import ProjectM36.Attribute (emptyAttributes)

10import ProjectM36.Attribute (emptyAttributes)

@@ -46,7 +47,11 @@ databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTu

47-- | Used to start a fresh database state for a new database context expression.

48-- | Used to start a fresh database state for a new database context expression.

48freshDatabaseState :: DatabaseContext -> DatabaseStateElems

49freshDatabaseState :: DatabaseContext -> DatabaseStateElems

50+freshDatabaseState context = DatabaseStateElems {

51+ context = context,

52+ accum = M.empty,

53+ dirty = False

49−freshDatabaseState ctx = (ctx, M.empty, False) --future work: propagate return accumulator

54+ } --future work: propagate return accumulator

51-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52

56-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52

52data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr

57data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr

@@ -80,19 +85,21 @@ data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,

80 resultAccumResult :: Relation

85 resultAccumResult :: Relation

81 }

86 }

88+data DatabaseStateElems = DatabaseStateElems {

89+ context :: DatabaseContext, --new, alterable context for a new transaction

83−type DatabaseStateElems = (DatabaseContext, M.Map ResultAccumName ResultAccum, DirtyFlag)

90+ accum :: M.Map ResultAccumName ResultAccum,

91+ dirty :: DirtyFlag

92+ }

85type DatabaseState a = State DatabaseStateElems a

94type DatabaseState a = State DatabaseStateElems a

87getStateContext :: DatabaseState DatabaseContext

96getStateContext :: DatabaseState DatabaseContext

88−getStateContext = do

97+getStateContext = context <$> get

89− (ctx,_, _) <- get

98+

90− pure ctx

91−

92putStateContext :: DatabaseContext -> DatabaseState ()

99putStateContext :: DatabaseContext -> DatabaseState ()

93−putStateContext ctx = do

100+putStateContext ctx' = do

94− (_, accum, _) <- get

101+ s <- get

95− put (ctx, accum, True)

102+ put (s {context = ctx'})

103

97type RelationalExprState a = Reader RelationalExprStateElems a

104type RelationalExprState a = Reader RelationalExprStateElems a

105

@@ -107,7 +114,7 @@ setStateElemsContext (RelationalExprStateElems _) ctx = RelationalExprStateElems

107setStateElemsContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs

114setStateElemsContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs

108

115

109--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values

116--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values

110−evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)

117+evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)

111evalRelationalExpr (RelationVariable name _) = do

118evalRelationalExpr (RelationVariable name _) = do

112 relvarTable <- fmap (relationVariables . stateElemsContext) ask

119 relvarTable <- fmap (relationVariables . stateElemsContext) ask

113 return $ case M.lookup name relvarTable of

120 return $ case M.lookup name relvarTable of

@@ -121,7 +128,7 @@ evalRelationalExpr (Project attrNames expr) = do

121 Right attrNameSet -> do

128 Right attrNameSet -> do

122 rel <- evalRelationalExpr expr

129 rel <- evalRelationalExpr expr

123 case rel of

130 case rel of

124− Right rel2 -> pure $ project attrNameSet rel2

131+ Right rel2 -> pure $ Right (Project (AttributeNames attrNameSet) rel2)

125 Left err -> pure $ Left err

132 Left err -> pure $ Left err

126

133

127evalRelationalExpr (Union exprA exprB) = do

134evalRelationalExpr (Union exprA exprB) = do

@@ -131,7 +138,7 @@ evalRelationalExpr (Union exprA exprB) = do

131 Left err -> return $ Left err

138 Left err -> return $ Left err

132 Right relA2 -> case relB of

139 Right relA2 -> case relB of

133 Left err -> return $ Left err

140 Left err -> return $ Left err

134− Right relB2 -> return $ union relA2 relB2

141+ Right relB2 -> return $ Right (Union relA2 relB2)

135

142

136evalRelationalExpr (Join exprA exprB) = do

143evalRelationalExpr (Join exprA exprB) = do

137 relA <- evalRelationalExpr exprA

144 relA <- evalRelationalExpr exprA

@@ -140,7 +147,7 @@ evalRelationalExpr (Join exprA exprB) = do

140 Left err -> return $ Left err

147 Left err -> return $ Left err

141 Right relA2 -> case relB of

148 Right relA2 -> case relB of

142 Left err -> return $ Left err

149 Left err -> return $ Left err

143− Right relB2 -> return $ join relA2 relB2

150+ Right relB2 -> return $ Right (Join relA2 relB2)

144

151

145evalRelationalExpr (Difference exprA exprB) = do

152evalRelationalExpr (Difference exprA exprB) = do

146 relA <- evalRelationalExpr exprA

153 relA <- evalRelationalExpr exprA

@@ -149,11 +156,11 @@ evalRelationalExpr (Difference exprA exprB) = do

149 Left err -> return $ Left err

156 Left err -> return $ Left err

150 Right relA2 -> case relB of

157 Right relA2 -> case relB of

151 Left err -> return $ Left err

158 Left err -> return $ Left err

152− Right relB2 -> return $ difference relA2 relB2

159+ Right relB2 -> return $ Right (Difference relA2 relB2)

153

160

154evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =

161evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =

155 case mkRelation attributeSet tupleSet of

162 case mkRelation attributeSet tupleSet of

156− Right rel -> return $ Right rel

163+ Right rel -> return $ Right (ExistingRelation rel)

157 Left err -> return $ Left err

164 Left err -> return $ Left err

158

165

159evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

166evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

@@ -168,14 +175,15 @@ evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

168 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs

175 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs

169 let attrs = fromMaybe firstTupleAttrs mAttrs

176 let attrs = fromMaybe firstTupleAttrs mAttrs

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

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

171− either throwE pure (mkRelation attrs (RelationTupleSet tuples))

178+ expr <- either throwE pure (mkRelation attrs (RelationTupleSet tuples))

179+ pure (ExistingRelation expr)

172

180

173−evalRelationalExpr (ExistingRelation rel) = pure (Right rel)

181+evalRelationalExpr (ExistingRelation rel) = pure (Right (ExistingRelation rel))

174

182

175evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

183evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

176 evald <- evalRelationalExpr relExpr

184 evald <- evalRelationalExpr relExpr

177 case evald of

185 case evald of

178− Right rel -> return $ rename oldAttrName newAttrName rel

186+ Right expr -> return $ Right (Rename oldAttrName newAttrName expr)

179 Left err -> return $ Left err

187 Left err -> return $ Left err

180

188

181evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do

189evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do

@@ -185,35 +193,33 @@ evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do

185 Right oldAttrNameSet -> do

193 Right oldAttrNameSet -> do

186 evald <- evalRelationalExpr relExpr

194 evald <- evalRelationalExpr relExpr

187 case evald of

195 case evald of

188− Right rel -> return $ group oldAttrNameSet newAttrName rel

196+ Right expr -> return $ Right (Group (AttributeNames oldAttrNameSet) newAttrName expr)

189 Left err -> return $ Left err

197 Left err -> return $ Left err

190

198

191evalRelationalExpr (Ungroup attrName relExpr) = do

199evalRelationalExpr (Ungroup attrName relExpr) = do

192 evald <- evalRelationalExpr relExpr

200 evald <- evalRelationalExpr relExpr

193 case evald of

201 case evald of

194− Right rel -> return $ ungroup attrName rel

202+ Right expr -> return $ Right (Ungroup attrName expr)

195 Left err -> return $ Left err

203 Left err -> return $ Left err

196

204

197evalRelationalExpr (Restrict predicateExpr relExpr) = do

205evalRelationalExpr (Restrict predicateExpr relExpr) = do

198 evald <- evalRelationalExpr relExpr

206 evald <- evalRelationalExpr relExpr

207+ ePred <- processRestrictionPredicateExpr predicateExpr

199 case evald of

208 case evald of

200 Left err -> return $ Left err

209 Left err -> return $ Left err

201− Right rel -> do

210+ Right expr -> case ePred of

202− eFilterFunc <- predicateRestrictionFilter (attributes rel) predicateExpr

211+ Left err -> pure (Left err)

203− case eFilterFunc of

212+ Right pred -> pure $ Right (Restrict pred expr)

204− Left err -> return $ Left err

205− Right filterfunc ->

206− pure (restrict filterfunc rel)

207

213

208evalRelationalExpr (Equals relExprA relExprB) = do

214evalRelationalExpr (Equals relExprA relExprB) = do

209 evaldA <- evalRelationalExpr relExprA

215 evaldA <- evalRelationalExpr relExprA

210 evaldB <- evalRelationalExpr relExprB

216 evaldB <- evalRelationalExpr relExprB

211 case evaldA of

217 case evaldA of

212 Left err -> return $ Left err

218 Left err -> return $ Left err

213− Right relA -> case evaldB of

219+ Right exprA -> case evaldB of

214 Left err -> return $ Left err

220 Left err -> return $ Left err

215− Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse

221+ Right exprB -> return $ Right (Equals exprA exprB)

216−

222+{-

217evalRelationalExpr (With views mainExpr) = do

223evalRelationalExpr (With views mainExpr) = do

218 rstate <- ask

224 rstate <- ask

219

225

@@ -231,36 +237,36 @@ evalRelationalExpr (With views mainExpr) = do

231 case evalMainExpr mainExpr of

237 case evalMainExpr mainExpr of

232 Left err -> return $ Left err

238 Left err -> return $ Left err

233 Right rel -> return $ Right rel

239 Right rel -> return $ Right rel

234−

240+-}

235--warning: copy-pasta from above- refactor

241--warning: copy-pasta from above- refactor

236evalRelationalExpr (NotEquals relExprA relExprB) = do

242evalRelationalExpr (NotEquals relExprA relExprB) = do

237 evaldA <- evalRelationalExpr relExprA

243 evaldA <- evalRelationalExpr relExprA

238 evaldB <- evalRelationalExpr relExprB

244 evaldB <- evalRelationalExpr relExprB

239 case evaldA of

245 case evaldA of

240 Left err -> return $ Left err

246 Left err -> return $ Left err

241− Right relA -> case evaldB of

247+ Right exprA -> case evaldB of

242 Left err -> return $ Left err

248 Left err -> return $ Left err

243− Right relB -> return $ Right $ if relA /= relB then relationTrue else relationFalse

249+ Right exprB -> return $ Right (NotEquals exprA exprB)

244

250

245-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated

251-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated

246evalRelationalExpr (Extend tupleExpression relExpr) = do

252evalRelationalExpr (Extend tupleExpression relExpr) = do

247− rstate <- ask

248− let evald = runReader (evalRelationalExpr relExpr) rstate

253+ eExpr <- evalRelationalExpr relExpr

249− case evald of

254+ case eExpr of

250 Left err -> pure (Left err)

255 Left err -> pure (Left err)

251− Right rel -> do

256+ Right expr -> do

252− tupProc <- extendTupleExpressionProcessor rel tupleExpression

257+ eTupProc <- processExtendTupleExpr tupleExpression

253− case tupProc of

258+ case eTupProc of

254 Left err -> pure (Left err)

259 Left err -> pure (Left err)

255− Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel

260+ Right tupProc -> pure (Right (Extend tupProc expr))

256

261

257--helper function to process relation variable creation/assignment

262--helper function to process relation variable creation/assignment

258−setRelVar :: RelVarName -> Relation -> DatabaseState (Either RelationalError ())

263+setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseState (Either RelationalError ())

259−setRelVar relVarName rel = do

264+setRelVar relVarName relExpr = do

260 currentContext <- getStateContext

265 currentContext <- getStateContext

261− let newRelVars = M.insert relVarName rel $ relationVariables currentContext

266+ let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext

262 potentialContext = currentContext { relationVariables = newRelVars }

267 potentialContext = currentContext { relationVariables = newRelVars }

263−

268+ --determine when to check constraints

269+

264 case checkConstraints potentialContext of

270 case checkConstraints potentialContext of

265 Left err -> pure (Left err)

271 Left err -> pure (Left err)

266 Right _ -> do

272 Right _ -> do

@@ -280,10 +286,10 @@ deleteRelVar relVarName = do

280 putStateContext newContext

286 putStateContext newContext

281 pure (Right ())

287 pure (Right ())

282

288

283−evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Either RelationalError ())

289+evalDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseState (Either RelationalError ())

284−evalDatabaseContextExpr NoOperation = pure (Right ())

290+evalDatabaseContextExpr NoOperation _ _ = pure (Right ())

285

291

286−evalDatabaseContextExpr (Define relVarName attrExprs) = do

292+evalDatabaseContextExpr (Define relVarName attrExprs) _ _ = do

287 relvars <- fmap relationVariables getStateContext

293 relvars <- fmap relationVariables getStateContext

288 tConss <- fmap typeConstructorMapping getStateContext

294 tConss <- fmap typeConstructorMapping getStateContext

289 let eAttrs = map (evalAttrExpr tConss) attrExprs

295 let eAttrs = map (evalAttrExpr tConss) attrExprs

@@ -298,84 +304,79 @@ evalDatabaseContextExpr (Define relVarName attrExprs) = do

298 else

304 else

299 case M.member relVarName relvars of

305 case M.member relVarName relvars of

300 True -> pure (Left (RelVarAlreadyDefinedError relVarName))

306 True -> pure (Left (RelVarAlreadyDefinedError relVarName))

301− False -> setRelVar relVarName emptyRelation >> pure (Right ())

307+ False -> setRelVar relVarName (ExistingRelation emptyRelation) >> pure (Right ())

302 where

308 where

303 attrs = A.attributesFromList attrsList

309 attrs = A.attributesFromList attrsList

304 emptyRelation = Relation attrs emptyTupleSet

310 emptyRelation = Relation attrs emptyTupleSet

305

311

306−evalDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName

312+evalDatabaseContextExpr (Undefine relVarName) _ _ = deleteRelVar relVarName

307

313

308−evalDatabaseContextExpr (Assign relVarName expr) = do

314+evalDatabaseContextExpr (Assign relVarName expr) transId graph = do

309− -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it

310− context <- getStateContext

311− let existingRelVar = M.lookup relVarName relVarTable

312− relVarTable = relationVariables context

313− value = runReader (evalRelationalExpr expr) (RelationalExprStateElems context)

314− case value of

315− Left err -> pure (Left err)

316− Right rel -> case existingRelVar of

317− Nothing -> setRelVar relVarName rel

318− Just existingRel -> let expectedAttributes = attributes existingRel

319− foundAttributes = attributes rel in

320− if A.attributesEqual expectedAttributes foundAttributes then

321− setRelVar relVarName rel

322− else

323− pure (Left (RelationTypeMismatchError expectedAttributes foundAttributes))

324−

325−evalDatabaseContextExpr (Insert relVarName relExpr) = do

326 context <- getStateContext

315 context <- getStateContext

327− let unionexp = Union relExpr rv

316+ let existingRelVar = M.lookup relVarName (relationVariables context)

328− rv = RelationVariable relVarName ()

317+ relExprState = mkRelationalExprState context

318+ case existingRelVar of

319+ Nothing -> do

329− unioned = runReader (evalRelationalExpr unionexp) (RelationalExprStateElems context)

320+ let ervExpr = runReader (evalRelationalExpr expr) relExprState

330− origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)

321+ case ervExpr of

331− case unioned of

322+ Left err -> pure (Left err)

323+ Right rvExpr -> setRelVar relVarName rvExpr

324+ Just existingRel -> do

325+ let eExpectedType = typeForGraphRefRelationalExpr existingRel transId graph

326+ eNewExprType = runReader (typeForRelationalExpr expr) relExprState

327+ case eExpectedType of

332− Left err -> pure (Left err)

328+ Left err -> pure (Left err)

333− Right unioned' -> case origRel of

329+ Right expectedType ->

330+ case eNewExprType of

334− Left err -> pure (Left err)

331+ Left err -> pure (Left err)

335− Right origRel' -> if cardinality unioned' == cardinality origRel' then --no tuples actually inserted

332+ Right newExprType -> do

336− pure (Right ())

333+ if newExprType == expectedType then do

334+ let ervExpr = runReader (evalRelationalExpr expr) relExprState

335+ case ervExpr of

336+ Left err -> pure (Left err)

337+ Right rvExpr -> setRelVar relVarName rvExpr

337− else

338+ else

338− evalDatabaseContextExpr $ Assign relVarName (ExistingRelation unioned')

339+ pure (Left (RelationTypeMismatchError (attributes expectedType) (attributes newExprType)))

339

340

340−evalDatabaseContextExpr (Delete relVarName predicate) = do

341+evalDatabaseContextExpr (Insert relVarName relExpr) tid graph =

341− context <- getStateContext

342− let rv = RelationVariable relVarName ()

342+ evalDatabaseContextExpr (Assign relVarName (Union (RelationVariable relVarName ())

343− let updatedRel = runReader (evalRelationalExpr (Restrict (NotPredicate predicate) rv)) (RelationalExprStateElems context)

343+ relExpr)) tid graph

344− origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)

345− case updatedRel of

346− Left err -> pure (Left err)

347− Right updatedRel' -> case origRel of

348− Left err -> pure (Left err)

349− Right origRel' -> if cardinality origRel' == cardinality updatedRel' then

350− pure (Right ())

351− else

352− setRelVar relVarName updatedRel'

353

344

345+evalDatabaseContextExpr (Delete relVarName predicate) transId _ = do

346+ ctx <- getStateContext

347+ let rv = RelationVariable relVarName transId

348+ rvState = mkRelationalExprState ctx

349+ case runReader (processRestrictionPredicateExpr predicate) rvState of

350+ Left err -> pure (Left err)

351+ Right graphRefPredicate ->

352+ setRelVar relVarName (Restrict (NotPredicate graphRefPredicate) rv)

353+

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

355−evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do

355+evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId _ = do

356 context <- getStateContext

357+ let rvState = mkRelationalExprState context

357− let relVarTable = relationVariables context

358+ relVarTable = relationVariables context

359+ case runReader (processRestrictionPredicateExpr restrictionPredicateExpr) rvState of

360+ Left err -> pure (Left err)

361+ Right graphRefPredicate ->

358− case M.lookup relVarName relVarTable of

362+ case M.lookup relVarName relVarTable of

359− Nothing -> pure (Left (RelVarNotDefinedError relVarName))

363+ Nothing -> pure (Left (RelVarNotDefinedError relVarName))

360− Just rel ->

364+ Just existingRvExpr -> do

361− case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of

365+ let unrestrictedPortion = Restrict (NotPredicate graphRefPredicate) rv

362− Left err -> pure (Left err)

366+ rv = RelationVariable relVarName transId

363− Right predicateFunc -> do

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

364− let ret = do

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

365− restrictedPortion <- restrict predicateFunc rel

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

366− if cardinality restrictedPortion == Finite 0 then

370+ restrictedPortion = Restrict graphRefPredicate

367− pure Nothing

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

368− else do

372+ let procAtomExpr = processAtomExpr atomExpr transId in

369− unrestrictedPortion <- restrict (predicateFunc >=> (pure . not)) rel

373+ updateAttr oldname procAtomExpr accum

370− updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion

374+ ) rv (M.toList atomExprMap)

371− updatedRel <- updatedPortion `union` unrestrictedPortion

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

372− pure (Just updatedRel)

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

373− case ret of

377+ setRelVar relVarName (Union unrestrictedPortion updatedPortion)

374− Left err -> pure (Left err)

375− Right Nothing -> pure (Right ())

376− Right (Just updatedRel) -> setRelVar relVarName updatedRel

377

378

378−evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do

379+evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) _ _ = do

379 currContext <- getStateContext

380 currContext <- getStateContext

380 let currDeps = inclusionDependencies currContext

381 let currDeps = inclusionDependencies currContext

381 newDeps = M.insert newDepName newDep currDeps

382 newDeps = M.insert newDepName newDep currDeps

@@ -389,7 +390,7 @@ evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do

389 putStateContext potentialContext

390 putStateContext potentialContext

390 return (Right ())

391 return (Right ())

391

392

392−evalDatabaseContextExpr (RemoveInclusionDependency depName) = do

393+evalDatabaseContextExpr (RemoveInclusionDependency depName) _ _ = do

393 currContext <- getStateContext

394 currContext <- getStateContext

394 let currDeps = inclusionDependencies currContext

395 let currDeps = inclusionDependencies currContext

395 newDeps = M.delete depName currDeps

396 newDeps = M.delete depName currDeps

@@ -400,7 +401,7 @@ evalDatabaseContextExpr (RemoveInclusionDependency depName) = do

400 return (Right ())

401 return (Right ())

401

402

402-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.

403-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.

403−evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do

404+evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) _ _ = do

404 currentContext <- getStateContext

405 currentContext <- getStateContext

405 let nots = notifications currentContext

406 let nots = notifications currentContext

406 if M.member notName nots then

407 if M.member notName nots then

@@ -413,7 +414,7 @@ evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resul

413 putStateContext $ currentContext { notifications = newNotifications }

414 putStateContext $ currentContext { notifications = newNotifications }

414 return (Right ())

415 return (Right ())

415

416

416−evalDatabaseContextExpr (RemoveNotification notName) = do

417+evalDatabaseContextExpr (RemoveNotification notName) _ _ = do

417 currentContext <- getStateContext

418 currentContext <- getStateContext

418 let nots = notifications currentContext

419 let nots = notifications currentContext

419 if M.notMember notName nots then

420 if M.notMember notName nots then

@@ -425,7 +426,7 @@ evalDatabaseContextExpr (RemoveNotification notName) = do

425

426

426-- | Adds type and data constructors to the database context.

427-- | Adds type and data constructors to the database context.

427-- validate that the type *and* constructor names are unique! not yet implemented!

428-- validate that the type *and* constructor names are unique! not yet implemented!

428−evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

429+evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) _ _ = do

429 currentContext <- getStateContext

430 currentContext <- getStateContext

430 let oldTypes = typeConstructorMapping currentContext

431 let oldTypes = typeConstructorMapping currentContext

431 tConsName = TCD.name tConsDef

432 tConsName = TCD.name tConsDef

@@ -440,7 +441,7 @@ evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

440 pure (Right ())

441 pure (Right ())

441

442

442-- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive.

443-- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive.

443−evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do

444+evalDatabaseContextExpr (RemoveTypeConstructor tConsName) _ _ = do

444 currentContext <- getStateContext

445 currentContext <- getStateContext

445 let oldTypes = typeConstructorMapping currentContext

446 let oldTypes = typeConstructorMapping currentContext

446 if isNothing (findTypeConstructor tConsName oldTypes) then

447 if isNothing (findTypeConstructor tConsName oldTypes) then

@@ -450,15 +451,15 @@ evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do

450 putStateContext $ currentContext { typeConstructorMapping = newTypes }

451 putStateContext $ currentContext { typeConstructorMapping = newTypes }

451 pure (Right ())

452 pure (Right ())

452

453

453−evalDatabaseContextExpr (MultipleExpr exprs) = do

454+evalDatabaseContextExpr (MultipleExpr exprs) transId graph = do

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

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

455− evald <- forM exprs evalDatabaseContextExpr

456+ evald <- forM exprs (\expr -> evalDatabaseContextExpr expr transId graph)

456 --some lifting magic needed here

457 --some lifting magic needed here

457 case lefts evald of

458 case lefts evald of

458 [] -> pure (Right ())

459 [] -> pure (Right ())

459 errs -> pure (Left (someErrors errs))

460 errs -> pure (Left (someErrors errs))

460

461

461−evalDatabaseContextExpr (RemoveAtomFunction funcName) = do

462+evalDatabaseContextExpr (RemoveAtomFunction funcName) _ _ = do

462 currentContext <- getStateContext

463 currentContext <- getStateContext

463 let atomFuncs = atomFunctions currentContext

464 let atomFuncs = atomFunctions currentContext

464 case atomFunctionForName funcName atomFuncs of

465 case atomFunctionForName funcName atomFuncs of

@@ -470,7 +471,7 @@ evalDatabaseContextExpr (RemoveAtomFunction funcName) = do

470 else

471 else

471 pure (Left (PrecompiledFunctionRemoveError funcName))

472 pure (Left (PrecompiledFunctionRemoveError funcName))

472

473

473−evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do

474+evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) _ _ = do

474 context <- getStateContext

475 context <- getStateContext

475 let dbcFuncs = dbcFunctions context

476 let dbcFuncs = dbcFunctions context

476 case databaseContextFunctionForName funcName dbcFuncs of

477 case databaseContextFunctionForName funcName dbcFuncs of

@@ -482,7 +483,7 @@ evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do

482 else

483 else

483 pure (Left (PrecompiledFunctionRemoveError funcName))

484 pure (Left (PrecompiledFunctionRemoveError funcName))

484

485

485−evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

486+evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) _ _ = do

486 context <- getStateContext

487 context <- getStateContext

487 --resolve atom arguments

488 --resolve atom arguments

488 let relExprState = mkRelationalExprState context

489 let relExprState = mkRelationalExprState context

@@ -515,8 +516,8 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) =

515 Left err -> pure (Left err)

516 Left err -> pure (Left err)

516 Right newContext -> putStateContext newContext >> pure (Right ())

517 Right newContext -> putStateContext newContext >> pure (Right ())

517

518

518−evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)

519+evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> TransactionId -> TransactionGraph -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)

519−evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) =

520+evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddAtomFunction funcName funcType script) =

520 case mScriptSession of

521 case mScriptSession of

521 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))

522 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))

522 Just scriptSession -> do

523 Just scriptSession -> do

@@ -548,7 +549,7 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcNam

548 Left err -> pure (Left err)

549 Left err -> pure (Left err)

549 Right context' -> pure (Right context')

550 Right context' -> pure (Right context')

550

551

551−evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) =

552+evalDatabaseContextIOExpr mScriptSession currentContext _ _ (AddDatabaseContextFunction funcName funcType script) =

552 case mScriptSession of

553 case mScriptSession of

553 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))

554 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))

554 Just scriptSession -> do

555 Just scriptSession -> do

@@ -587,14 +588,14 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct

587 Right eContext -> case eContext of

588 Right eContext -> case eContext of

588 Left err -> pure (Left err)

589 Left err -> pure (Left err)

589 Right context' -> pure (Right context')

590 Right context' -> pure (Right context')

590−evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do

591+evalDatabaseContextIOExpr _ currentContext _ _ (LoadAtomFunctions modName funcName modPath) = do

591 eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath

592 eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath

592 case eLoadFunc of

593 case eLoadFunc of

593 Left LoadSymbolError -> pure (Left LoadFunctionError)

594 Left LoadSymbolError -> pure (Left LoadFunctionError)

594 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }

595 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }

595 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)

596 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)

596 in pure (Right newContext)

597 in pure (Right newContext)

597−evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName funcName modPath) = do

598+evalDatabaseContextIOExpr _ currentContext _ _ (LoadDatabaseContextFunctions modName funcName modPath) = do

598 eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath

599 eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath

599 case eLoadFunc of

600 case eLoadFunc of

600 Left LoadSymbolError -> pure (Left LoadFunctionError)

601 Left LoadSymbolError -> pure (Left LoadFunctionError)

@@ -602,26 +603,29 @@ evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName

602 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)

603 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)

603 in pure (Right newContext)

604 in pure (Right newContext)

604

605

605−evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) =

606+evalDatabaseContextIOExpr _ currentContext transId graph (CreateArbitraryRelation relVarName attrExprs range) =

606 --Define

607 --Define

607− case runState ( evalDatabaseContextExpr (Define relVarName attrExprs)) (freshDatabaseState currentContext) of

608+ case runState (evalDatabaseContextExpr (Define relVarName attrExprs) transId graph) (freshDatabaseState currentContext) of

608 (Left err,_) -> pure (Left err)

609 (Left err,_) -> pure (Left err)

609− (Right (), elems@(ctx,_,_)) -> do

610+ (Right (), elems) -> do

610 --Assign

611 --Assign

611 let existingRelVar = M.lookup relVarName relVarTable

612 let existingRelVar = M.lookup relVarName relVarTable

612− relVarTable = relationVariables ctx

613+ relVarTable = relationVariables (context elems)

613 case existingRelVar of

614 case existingRelVar of

614 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

615 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

615 Just existingRel -> do

616 Just existingRel -> do

616− let expectedAttributes = attributes existingRel

617+ case typeForGraphRefRelationalExpr existingRel transId graph of

618+ Left err -> pure (Left err)

619+ Right relType -> do

620+ let expectedAttributes = attributes relType

617− let tcMap = typeConstructorMapping ctx

621+ tcMap = typeConstructorMapping (context elems)

618− eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap

622+ eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap

619− case eitherRel of

623+ case eitherRel of

620− Left err -> pure $ Left err

624+ Left err -> pure $ Left err

621− Right rel ->

625+ Right rel ->

622− case runState (setRelVar relVarName rel) elems of

626+ case runState (setRelVar relVarName (ExistingRelation rel)) elems of

623− (Left err,_) -> pure (Left err)

627+ (Left err,_) -> pure (Left err)

624− (Right (), (ctx',_,_)) -> pure $ Right ctx'

628+ (Right (), elems') -> pure $ Right (context elems)

625

629

626updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

630updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

627updateTupleWithAtomExprs exprMap context tupIn = do

631updateTupleWithAtomExprs exprMap context tupIn = do

@@ -683,7 +687,7 @@ liftE v = do

683 Right val -> pure val

687 Right val -> pure val

684

688

685{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}

689{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}

686−predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionFilter)

690+predicateRestrictionFilter :: Attributes -> RestrictionPredicateExprBase a -> RelationalExprState (Either RelationalError RestrictionFilter)

687predicateRestrictionFilter attrs (AndPredicate expr1 expr2) =

691predicateRestrictionFilter attrs (AndPredicate expr1 expr2) =

688 runExceptT $ do

692 runExceptT $ do

689 expr1v <- liftE (predicateRestrictionFilter attrs expr1)

693 expr1v <- liftE (predicateRestrictionFilter attrs expr1)

@@ -1000,3 +1004,49 @@ evalAttributeNames attrNames expr = do

1000 Left err -> pure (Left err)

1004 Left err -> pure (Left err)

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

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

1002

1006

1007+evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation

1008+evalGraphRefRelationalExpr (RelationVariable name tid) graph = do

1009+ ctx <- dbContextForTransId tid graph

1010+ case M.lookup name (relationVariables ctx) of

1011+ Nothing -> Left (RelVarNotDefinedError name)

1012+ Just rv -> evalGraphRefRelationalExpr rv graph

1013+

1014+dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext

1015+dbContextForTransId tid graph = do

1016+ trans <- transactionForId tid graph

1017+ pure (concreteDatabaseContext ctx)

1018+

1019+transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction

1020+transactionForId tid graph

1021+ | tid == U.nil =

1022+ Left RootTransactionTraversalError

1023+ | S.null matchingTrans =

1024+ Left $ NoSuchTransactionError tid

1025+ | otherwise =

1026+ Right $ head (S.toList matchingTrans)

1027+ where

1028+ matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)

1029+

1030+processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState (Either RelationalError GraphRefRestrictionPredicateExpr)

1031+processRestrictionPredicateExpr TruePredicate = TruePredicate

1032+processRestrictionPredicateExpr (AndPredicate a b) = pure $ AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b

1033+processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b

1034+processRestrictionPredicateExpr (NotPredicate a) = pure $ NotPredicate <$> processRestrictionPredicateExpr a

1035+processRestrictionPredicateExpr (RelationalExprPredicate expr) = pure $ RelationalExprPredicate <$> evalRelationalExpr expr

1036+processRestrictionPredicateExpr (AtomExprPredicate expr) = AtomExprPredicate <$> evalAtomExpr expr

1037+processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = AttributeEqualityPredicate nam <$> evalAtomExpr expr

1038+

1039+processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError (ExtendTupleExprBase a))

1040+processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do

1041+ eExpr <- evalAtomExpr atomExpr

1042+ case eExpr of

1043+ Left err -> pure (Left err)

1044+ Right expr -> pure (Right (AttributeExtendTupleExpr nam expr))

1045+

1046+typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionId -> TransactionGraph -> Either RelationalError Relation

1047+typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = mkRelation attrs emptyTupleSet

1048+typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))

1049+typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = unimplemented

1050+

1051+processAtomExpr :: AtomExpr -> TransactionId -> GraphRefAtomExpr

1052+processAtomExpr = unimplemented

src/lib/ProjectM36/Transaction/Persist.hs+11−19

@@ -36,8 +36,8 @@ transactionDir dbdir transId = dbdir </> show transId

36transactionInfoPath :: FilePath -> FilePath

37transactionInfoPath transdir = transdir </> "info"

39−relvarsDir :: FilePath -> FilePath

39+relvarsPath :: FilePath -> FilePath

40−relvarsDir transdir = transdir </> "relvars"

40+relvarsPath transdir = transdir </> "relvars"

42incDepsDir :: FilePath -> FilePath

43incDepsDir transdir = transdir </> "incdeps"

@@ -85,7 +85,7 @@ writeTransaction sync dbdir trans = do

85 transDirExists <- doesDirectoryExist finalTransDir

86 unless transDirExists $ do

87 --create sub directories

88− mapM_ createDirectory [tempTransDir, relvarsDir tempTransDir, incDepsDir tempTransDir, dbcFuncsDir tempTransDir]

88+ mapM_ createDirectory [tempTransDir, incDepsDir tempTransDir, dbcFuncsDir tempTransDir]

89 writeRelVars sync tempTransDir (relationVariables context)

90 writeIncDeps sync tempTransDir (inclusionDependencies context)

91 writeAtomFuncs sync tempTransDir (atomFunctions context)

@@ -95,23 +95,15 @@ writeTransaction sync dbdir trans = do

95 B.encodeFile (transactionInfoPath tempTransDir) (transactionInfo trans)

96 --move the temp directory to final location

97 renameSync sync tempTransDir finalTransDir

98−

99−writeRelVar :: DiskSync -> FilePath -> (RelVarName, Relation) -> IO ()

100−writeRelVar sync transDir (relvarName, rel) = do

101− let relvarPath = relvarsDir transDir </> T.unpack relvarName

102− writeBSFileSync sync relvarPath (compress (B.encode rel))

103−

104−writeRelVars :: DiskSync -> FilePath -> M.Map RelVarName Relation -> IO ()

105−writeRelVars sync transDir relvars = mapM_ (writeRelVar sync transDir) $ M.toList relvars

106

107−readRelVars :: FilePath -> IO (M.Map RelVarName Relation)

99+writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO ()

100+writeRelVars sync transDir relvars = do

101+ let path = relvarsPath transDir

102+ writeBSFileSync sync path (B.encode relvars)

103+

104+readRelVars :: FilePath -> IO RelationVariables

108readRelVars transDir = do

105readRelVars transDir = do

109− let relvarsPath = relvarsDir transDir

106+ B.decodeFile (relvarsPath transDir)

110− relvarNames <- getDirectoryNames relvarsPath

111− let relvars = mapM (\name -> do

112− rel <- B.decode . decompress . BSL.fromStrict <$> BS.readFile (relvarsPath </> name)

113− return (T.pack name, rel)) relvarNames

114− M.fromList <$> relvars

115

107

116writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO ()

108writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO ()

117writeAtomFuncs sync transDir funcs = do

109writeAtomFuncs sync transDir funcs = do

@@ -252,4 +244,4 @@ readTypeConstructorMapping path = do

252 let atPath = typeConsPath path

244 let atPath = typeConsPath path

253 B.decodeFile atPath

245 B.decodeFile atPath

254

246

255−

247+

src/lib/ProjectM36/TransactionGraph.hs−11

@@ -94,17 +94,6 @@ transactionHeadsForGraph (TransactionGraph hs _) = hs

94transactionsForGraph :: TransactionGraph -> S.Set Transaction

95transactionsForGraph (TransactionGraph _ ts) = ts

97−transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction

98−transactionForId tid graph

99− | tid == U.nil =

100− Left RootTransactionTraversalError

101− | S.null matchingTrans =

102− Left $ NoSuchTransactionError tid

103− | otherwise =

104− Right $ head (S.toList matchingTrans)

105− where

106− matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)

107−

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

97transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)

109transactionsForIds idSet graph =

98transactionsForIds idSet graph =

110 S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)

99 S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)

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

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

43 lookupA = findRel relvarsA

44 lookupB = findRel relvarsB

45 case (lookupA, lookupB) of

46− (Just relA, Just relB) ->

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

47− unionMergeRelation prefer relA relB

47+ --unionMergeRelation prefer relA relB

48 (Nothing, Just relB) -> pure relB

49 (Just relA, Nothing) -> pure relA

50 (Nothing, Nothing) -> error "impossible relvar naming lookup"