a0e6f44 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

polish up database context function work

a0e6f44AgentM10 years ago

docs/database_context_functions.markdownnew file+117

compare with master

unifiedsplit

@@ -0,0 +1,117 @@

1+# Project:M36 Database Context Functions

3+## Introduction

5+While "atom functions" operate on individual values and return new values (atoms), database context functions operate on pre-committed database contexts in the same context as the ```update```, ```insert```, and ```delete``` operators. The difference is that database context functions are written in Haskell and support any number of context changes.

7+Other DBMS software may include a similar feature called "stored procedures". However, "stored procedures" are stored outside the transaction stream and are not versioned by the database as in Project:M36.

9+In order to use this feature in Project:M36, be sure to build your own Project:M36 library so that the optional scripting is enabled.

10+

11+## Database Context Function Types

12+

13+The Haskell type of all database context functions is:

14+

15+```haskell

16+[Atom] -> DatabaseContext -> DatabaseContext

17+```

18+

19+That is, the function takes an array of ```Atom```s which represent the function's arguments and a context and returns an updated context. Notice that this operation is idempotent ("pure" in Haskell parlance).

20+

21+The database context references all data which can be committed; this includes relation variables, atom functions, notifications, database context functions, and other versionable data. Database contexts become immutable once committed.

22+

23+## Scope of Database Context Functions

24+

25+Database context functions are committed alongside the transaction. Thus, previous versions of the functions can be explored or restored. Like all database context elements, database context functions are immutable once committed. However, the transaction graph can be branched in order to examine how database context functions changes might apply to future contexts.

26+

27+Remember that database context functions don't need to worry about locks or other synchronization. The database context is completely isolated from other ongoing transactions.

28+

29+## TutorialD Demonstration

30+

31+Use ```adddatabasecontextfunction``` to compile and name a new database context function:

32+

33+```

34+adddatabasecontextfunction "addperson" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> let newrel = MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", NakedAtomExpr name),("age", NakedAtomExpr age)])] in if isRight (evalState (evalRelationalExpr (RelationVariable "person" ())) (mkRelationalExprState ctx)) then execState (evalDatabaseContextExpr (Insert "person" newrel)) ctx else execState (evalDatabaseContextExpr (Assign "person" newrel)) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""

35+```

36+

37+This function is quite dense, so let's examine its components.

38+

39+The first components are:

40+

41+```

42+adddatabasecontextfunction "addperson" Int -> Text -> DatabaseContext -> DatabaseContext

43+```

44+

45+which defines a function "addperson" which takes three arguments (an Int value, a Text value, and a DatabaseContext) and returns a DatabaseContext. All database context functions take as a final argument a database context and must return a database context.

46+

47+The meat of the function is obviously the Haskell, so let's lay it out:

48+

49+```haskell

50+(\(age:name:_) ctx -> let newrel = MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", NakedAtomExpr name),("age", NakedAtomExpr age)])] in

51+ if isRight (evalState (evalRelationalExpr (RelationVariable "person" ())) (mkRelationalExprState ctx)) then

52+ execState (evalDatabaseContextExpr (Insert "person" newrel)) ctx

53+ else

54+ execState (evalDatabaseContextExpr (Assign "person" newrel)) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext

55+```

56+

57+Line 1 sets up a new relation created from the function's arguments. In this case, we create a relation to represent a new person in our database.

58+

59+Line 2 determines if the "person" relation variable is already available in the context. If so, the function inserts the new "person" relation into the existing relation variable in line 3.

60+

61+In line 5, since the relation variable was determined not yet to be defined, we assign the new person relation directly.

62+

63+Note that there is nothing special about the Haskell above- it is indeed a full-blown Haskell environment; however, this environment operates in "Safe" mode which prohibits any non-pure function access (such as with ```unsafePerformIO```). Thus, it is safe to use as a trusted programming environment with users creating arbitrary convenience functions within the implicit sandbox.

64+

65+Users can add arbitrary (but safe and pure) calculations to these functions to capture business logic. The list of modules available within the function context can be modified at compile-time.

66+

67+Let's try the new function!

68+

69+```

70+TutorialD (master/main): execute addperson(30, "Steve")

71+TutorialD (master/main): :showexpr person

72+┌────────┬──────────┐

73+│age::Int│name::Text│

74+├────────┼──────────┤

75+│30 │"Steve" │

76+└────────┴──────────┘

77+TutorialD (master/main): execute addperson(32, "Bob")

78+TutorialD (master/main): :showexpr person

79+┌────────┬──────────┐

80+│age::Int│name::Text│

81+├────────┼──────────┤

82+│32 │"Bob" │

83+│30 │"Steve" │

84+└────────┴──────────┘

85+TutorialD (master/main):

86+```

87+

88+Here we see that the first call to ```addperson``` created the relation variable while a subsequent call added another tuple to the existing relation variable.

89+

90+## Haskell access

91+

92+Database context functions come in two varieties:

93+

94+* scripted (as above)

95+* pre-compiled

96+

97+If you are dealing with the Haskell interface directly and you don't anticipate changing the functions, the easiest option is to compile your Haskell database context function into the database. It can always be removed or supplanted by a scripted version later.

98+

99+To add a new, compiled database context function to the database, use:

100+

101+```haskell

102+executeDatabaseContextIOExpr sessionId dbconn (AddDatabaseContextFunction funcName Nothing (\(arg1:arg2:_) ctx -> ...))

103+```

104+from the ```ProjectM36.Client``` module.

105+

106+The function can be executed using:

107+

108+```haskell

109+executeDatabaseContextExpr sessionId dbconn (ExecuteDatabaseContextFunction funcName atomArgList)

110+```

111+from the same module.

112+

113+## Future Improvements

114+

115+There are likely a variety of convenience functions which would make sense in the context of the scripted function. If you have ideas for such functions, please open a GitHub issue.

116+

117+Error-handling is currently based on exceptions thrown from the functions. It would likely be smoother to be able to return errors from the functions instead.

project-m36.cabal+11

@@ -284,6 +284,17 @@ Test-Suite test-tutoriald-atomfunctionscript

284 Hs-Source-Dirs: ./src/bin, ./test, .

285 CPP-Options: -DPROJECTM36_VERSION="v0.1"

286

287+Test-Suite test-tutoriald-databasecontextfunctionscript

288+ Default-Language: Haskell2010

289+ Default-Extensions: OverloadedStrings

290+ type: exitcode-stdio-1.0

291+ Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator

292+ main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs

293+ Build-Depends: base, HUnit, project-m36 == 0.1, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom

294+ GHC-Options: -Wall

295+ Hs-Source-Dirs: ./src/bin, ./test, .

296+ CPP-Options: -DPROJECTM36_VERSION="v0.1"

297+

287Test-Suite test-relation

298Test-Suite test-relation

288 Default-Language: Haskell2010

299 Default-Language: Haskell2010

289 Default-Extensions: OverloadedStrings

300 Default-Extensions: OverloadedStrings

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+4−3

@@ -11,7 +11,7 @@ import Control.Monad.State

11import ProjectM36.StaticOptimizer

12import qualified ProjectM36.Error as PM36E

13import ProjectM36.Error

14−import ProjectM36.RelationalExpression

14+import qualified ProjectM36.RelationalExpression as RE

15import ProjectM36.Key

16import ProjectM36.FunctionalDependency

17import Data.Monoid

@@ -33,6 +33,7 @@ databaseContextExprP = choice [insertP,

33 addTypeConstructorP,

34 removeTypeConstructorP,

35 executeDatabaseContextFunctionP,

36+ removeDatabaseContextFunctionP,

36 nothingP]

37 nothingP]

38nothingP :: Parser DatabaseContextExpr

39nothingP :: Parser DatabaseContextExpr

@@ -190,14 +191,14 @@ executeDatabaseContextFunctionP = do

190 funcName <- identifier

191 funcName <- identifier

191 args <- parens (sepBy atomExprP comma)

192 args <- parens (sepBy atomExprP comma)

192 pure (ExecuteDatabaseContextFunction funcName args)

193 pure (ExecuteDatabaseContextFunction funcName args)

193−

194+

194databaseExprOpP :: Parser DatabaseContextExpr

195databaseExprOpP :: Parser DatabaseContextExpr

195databaseExprOpP = multipleDatabaseContextExprP

196databaseExprOpP = multipleDatabaseContextExprP

196

197

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

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

198evalDatabaseContextExpr useOptimizer context expr = do

199evalDatabaseContextExpr useOptimizer context expr = do

199 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context

200 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context

200− case runState (evalContextExpr (if useOptimizer then optimizedExpr else expr)) context of

201+ case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) context of

201 (Nothing, context') -> Right context'

202 (Nothing, context') -> Right context'

202 (Just err, _) -> Left err

203 (Just err, _) -> Left err

203

204

src/bin/benchmark/bigrel.hs+1−1

@@ -59,7 +59,7 @@ matrixRun (BigrelArgs attributeCount tupleCount tutd) = do

59 putStrLn "Done."

60 else do

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

62− context = execState (evalContextExpr setx) dateExamples

62+ context = execState (evalDatabaseContextExpr setx) dateExamples

63 interpreted = interpretDatabaseContextExpr context tutd

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

65 --displayOpResult plan

src/lib/ProjectM36/Base.hs+26−48

@@ -89,15 +89,11 @@ isRelationAtomType _ = False

89type AttributeName = StringType

91-- | A relation's type is composed of attribute names and types.

92−data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic)

92+data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic, NFData, Binary)

94instance Hashable Attribute where

95 hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName

97−instance NFData Attribute where rnf = genericRnf

98−

99−instance Binary Attribute

100−

101-- | 'Attributes' represent the head of a relation.

97-- | 'Attributes' represent the head of a relation.

102type Attributes = V.Vector Attribute

98type Attributes = V.Vector Attribute

103

@@ -210,10 +206,10 @@ data RelationalExprBase a =

210 NotEquals (RelationalExprBase a) (RelationalExprBase a) |

206 NotEquals (RelationalExprBase a) (RelationalExprBase a) |

211 Extend (ExtendTupleExprBase a) (RelationalExprBase a)

207 Extend (ExtendTupleExprBase a) (RelationalExprBase a)

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

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

213− deriving (Show, Eq, Generic)

209+ deriving (Show, Eq, Generic, NFData)

210+

211+instance Binary RelationalExpr

214

212

215−instance Binary RelationalExpr

216−

217type NotificationName = StringType

213type NotificationName = StringType

218type Notifications = M.Map NotificationName Notification

214type Notifications = M.Map NotificationName Notification

219

215

@@ -222,7 +218,7 @@ data Notification = Notification {

222 changeExpr :: RelationalExpr,

218 changeExpr :: RelationalExpr,

223 reportExpr :: RelationalExpr

219 reportExpr :: RelationalExpr

224 }

220 }

225− deriving (Show, Eq, Binary, Generic)

221+ deriving (Show, Eq, Binary, Generic, NFData)

226

222

227type TypeVarName = StringType

223type TypeVarName = StringType

228

224

@@ -248,7 +244,7 @@ type DataConstructorName = StringType

248type AtomTypeName = StringType

244type AtomTypeName = StringType

249

245

250-- | Used to define a data constructor in a type constructor context. (Left a | Right b)

246-- | Used to define a data constructor in a type constructor context. (Left a | Right b)

251−data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Binary, Generic)

247+data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Binary, Generic, NFData)

252

248

253type DataConstructorDefs = [DataConstructorDef]

249type DataConstructorDefs = [DataConstructorDef]

254

250

@@ -286,12 +282,12 @@ data DatabaseContext = DatabaseContext {

286 dbcFunctions :: DatabaseContextFunctions,

282 dbcFunctions :: DatabaseContextFunctions,

287 notifications :: Notifications,

283 notifications :: Notifications,

288 typeConstructorMapping :: TypeConstructorMapping

284 typeConstructorMapping :: TypeConstructorMapping

289− }

285+ } deriving (NFData, Generic)

290

286

291type IncDepName = StringType

287type IncDepName = StringType

292

288

293-- | Inclusion dependencies represent every possible database constraints. Constraints enforce specific, arbitrarily-complex rules to which the database context must adhere.

289-- | Inclusion dependencies represent every possible database constraints. Constraints enforce specific, arbitrarily-complex rules to which the database context must adhere.

294−data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic)

290+data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic, NFData)

295

291

296instance Binary InclusionDependency

292instance Binary InclusionDependency

297

293

@@ -343,7 +339,7 @@ data RestrictionPredicateExprBase a =

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

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

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

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

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

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

346− deriving (Show, Eq, Generic)

342+ deriving (Show, Eq, Generic, NFData)

347

343

348instance Binary RestrictionPredicateExpr

344instance Binary RestrictionPredicateExpr

349

345

@@ -399,13 +395,13 @@ data AtomExprBase a = AttributeAtomExpr AttributeName |

399 FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |

395 FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |

400 RelationAtomExpr (RelationalExprBase a) |

396 RelationAtomExpr (RelationalExprBase a) |

401 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

397 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

402− deriving (Eq,Show,Generic)

398+ deriving (Eq,Show,Generic, NFData)

403

399

404instance Binary AtomExpr

400instance Binary AtomExpr

405

401

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

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

407data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

403data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

408− deriving (Show, Eq, Generic)

404+ deriving (Show, Eq, Generic, NFData)

409

405

410type ExtendTupleExpr = ExtendTupleExprBase ()

406type ExtendTupleExpr = ExtendTupleExprBase ()

411

407

@@ -421,6 +417,9 @@ type AtomFunctionBodyScript = StringType

421type AtomFunctionBodyType = [Atom] -> Atom

417type AtomFunctionBodyType = [Atom] -> Atom

422

418

423data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType

419data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType

420+

421+instance NFData AtomFunctionBody where

422+ rnf (AtomFunctionBody mScript _) = rnf mScript

424

423

425instance Show AtomFunctionBody where

424instance Show AtomFunctionBody where

426 show (AtomFunctionBody mScript _) = case mScript of

425 show (AtomFunctionBody mScript _) = case mScript of

@@ -432,24 +431,13 @@ data AtomFunction = AtomFunction {

432 atomFuncName :: AtomFunctionName,

431 atomFuncName :: AtomFunctionName,

433 atomFuncType :: [AtomType],

432 atomFuncType :: [AtomType],

434 atomFuncBody :: AtomFunctionBody

433 atomFuncBody :: AtomFunctionBody

435− }

434+ } deriving (Generic, NFData)

436

435

437instance Hashable AtomFunction where

436instance Hashable AtomFunction where

438 hashWithSalt salt func = salt `hashWithSalt` (atomFuncName func)

437 hashWithSalt salt func = salt `hashWithSalt` (atomFuncName func)

439

438

440instance Eq AtomFunction where

439instance Eq AtomFunction where

441− f1 == f2 = let (AtomFunctionBody mScript1 _) = atomFuncBody f1

442− (AtomFunctionBody mScript2 _) = atomFuncBody f2 in

443− if atomFuncName f1 == atomFuncName f2 then

440+ f1 == f2 = atomFuncName f1 == atomFuncName f2

444− if isJust mScript1 then

445− if mScript1 == mScript2 then

446− True

447− else

448− False

449− else

450− True

451− else

452− False

453

441

454instance Show AtomFunction where

442instance Show AtomFunction where

455 show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes ++ "; " ++ body

443 show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes ++ "; " ++ body

@@ -462,10 +450,8 @@ data AttributeNames = AttributeNames (S.Set AttributeName) |

462 InvertedAttributeNames (S.Set AttributeName) |

450 InvertedAttributeNames (S.Set AttributeName) |

463 UnionAttributeNames AttributeNames AttributeNames |

451 UnionAttributeNames AttributeNames AttributeNames |

464 IntersectAttributeNames AttributeNames AttributeNames

452 IntersectAttributeNames AttributeNames AttributeNames

465− deriving (Eq, Show, Generic)

453+ deriving (Eq, Show, Generic, Binary, NFData)

466

454

467−instance Binary AttributeNames

468−

469-- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all.

455-- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all.

470data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory-only database

456data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory-only database

471 MinimalPersistence FilePath | -- ^ fsync off, not crash-safe

457 MinimalPersistence FilePath | -- ^ fsync off, not crash-safe

@@ -476,12 +462,12 @@ type AttributeExpr = AttributeExprBase ()

476

462

477data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

463data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

478 NakedAttributeExpr Attribute

464 NakedAttributeExpr Attribute

479− deriving (Eq, Show, Generic, Binary)

465+ deriving (Eq, Show, Generic, Binary, NFData)

480

466

481data TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))

467data TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))

482− deriving (Eq, Show, Generic)

468+ deriving (Eq, Show, Generic, NFData)

483

469

484−instance Binary TupleExpr

470+instance Binary TupleExpr

485

471

486type TupleExpr = TupleExprBase ()

472type TupleExpr = TupleExprBase ()

487

473

@@ -500,13 +486,16 @@ type DatabaseContextFunctionBodyScript = StringType

500

486

501type DatabaseContextFunctionBodyType = [Atom] -> DatabaseContext -> DatabaseContext

487type DatabaseContextFunctionBodyType = [Atom] -> DatabaseContext -> DatabaseContext

502

488

503−data DatabaseContextFunctionBody = DatabaseContextFunctionBody (Maybe DatabaseContextFunctionBodyScript) DatabaseContextFunctionBodyType

489+data DatabaseContextFunctionBody = DatabaseContextFunctionBody (Maybe DatabaseContextFunctionBodyScript) DatabaseContextFunctionBodyType

490+

491+instance NFData DatabaseContextFunctionBody where

492+ rnf (DatabaseContextFunctionBody mScript _) = rnf mScript

504

493

505data DatabaseContextFunction = DatabaseContextFunction {

494data DatabaseContextFunction = DatabaseContextFunction {

506 dbcFuncName :: DatabaseContextFunctionName,

495 dbcFuncName :: DatabaseContextFunctionName,

507 dbcFuncType :: [AtomType],

496 dbcFuncType :: [AtomType],

508 dbcFuncBody :: DatabaseContextFunctionBody

497 dbcFuncBody :: DatabaseContextFunctionBody

509− }

498+ } deriving (Generic, NFData)

510

499

511type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction

500type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction

512

501

@@ -514,15 +503,4 @@ instance Hashable DatabaseContextFunction where

514 hashWithSalt salt func = salt `hashWithSalt` (dbcFuncName func)

503 hashWithSalt salt func = salt `hashWithSalt` (dbcFuncName func)

515

504

516instance Eq DatabaseContextFunction where

505instance Eq DatabaseContextFunction where

517− f1 == f2 = let (DatabaseContextFunctionBody mScript1 _) = dbcFuncBody f1

518− (DatabaseContextFunctionBody mScript2 _) = dbcFuncBody f2 in

519− if dbcFuncName f1 == dbcFuncName f2 then

506+ f1 == f2 = dbcFuncName f1 == dbcFuncName f2

520− if isJust mScript1 then

521− if mScript1 == mScript2 then

522− True

523− else

524− False

525− else

526− True

527− else

528− False

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

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

1−{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables #-}

1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, BangPatterns #-}

2module ProjectM36.Client

3 (ConnectionInfo(..),

4 Connection(..),

@@ -392,7 +392,7 @@ close :: Connection -> IO ()

392close (InProcessConnection conf) = do

393 atomically $ do

394 let sessions = ipSessions conf

395− traverse_ (\(k,_) -> STMMap.delete k sessions) (STMMap.stream sessions)

395+ STMMap.deleteAll sessions

396 pure ()

397 closeLocalNode (ipLocalNode conf)

398 closeTransport (ipTransport conf)

@@ -533,9 +533,9 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excMaybe

533 Schema.processDatabaseContextExprInSchema schema expr

534 case expr' of

535 Left err -> pure (Just err)

536− Right expr'' -> case runState (RE.evalContextExpr expr'') (Sess.concreteDatabaseContext session) of

536+ Right expr'' -> case runState (RE.evalDatabaseContextExpr expr'') (Sess.concreteDatabaseContext session) of

537 (Just err,_) -> return $ Just err

538− (Nothing, context') -> do

538+ (Nothing, !context') -> do

539 let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas

540 newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr

541 newSchemas = Schemas context' newSubschemas

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

@@ -327,7 +327,7 @@ evalSchemaExpr (AddSubschema sname morphs) context sschemas = do

327 moreIncDeps = foldr (\morph acc -> M.union acc (createIncDepsForIsomorph sname morph)) M.empty morphs

328 incDepExprs = MultipleExpr (map (uncurry AddInclusionDependency) (M.toList moreIncDeps))

329 in

330− case runState (evalContextExpr incDepExprs) context of

330+ case runState (evalDatabaseContextExpr incDepExprs) context of

331 (Just err, _) -> Left err

332 (Nothing, newContext) -> pure (newSchemas, newContext)

333 where

src/lib/ProjectM36/RelationalExpression.hs+41−38

@@ -26,6 +26,7 @@ import Control.Monad.Trans.Except

27import GHC

28import GHC.Paths

29+import Debug.Trace

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

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

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

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

@@ -209,10 +210,10 @@ deleteRelVar relVarName = do

209 put newContext

210 put newContext

210 return Nothing

211 return Nothing

211

212

212−evalContextExpr :: DatabaseContextExpr -> DatabaseState (Maybe RelationalError)

213+evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Maybe RelationalError)

213−evalContextExpr NoOperation = pure Nothing

214+evalDatabaseContextExpr NoOperation = pure Nothing

214

215

215−evalContextExpr (Define relVarName attrExprs) = do

216+evalDatabaseContextExpr (Define relVarName attrExprs) = do

216 relvars <- liftM relationVariables get

217 relvars <- liftM relationVariables get

217 tConss <- liftM typeConstructorMapping get

218 tConss <- liftM typeConstructorMapping get

218 let eAttrs = map (evalAttrExpr tConss) attrExprs

219 let eAttrs = map (evalAttrExpr tConss) attrExprs

@@ -225,10 +226,10 @@ evalContextExpr (Define relVarName attrExprs) = do

225 attrs = A.attributesFromList (rights eAttrs)

226 attrs = A.attributesFromList (rights eAttrs)

226 emptyRelation = Relation attrs emptyTupleSet

227 emptyRelation = Relation attrs emptyTupleSet

227

228

228−evalContextExpr (Undefine relVarName) = do

229+evalDatabaseContextExpr (Undefine relVarName) = do

229 deleteRelVar relVarName

230 deleteRelVar relVarName

230

231

231−evalContextExpr (Assign relVarName expr) = do

232+evalDatabaseContextExpr (Assign relVarName expr) = do

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

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

233 context <- get

234 context <- get

234 let existingRelVar = M.lookup relVarName relVarTable

235 let existingRelVar = M.lookup relVarName relVarTable

@@ -245,9 +246,9 @@ evalContextExpr (Assign relVarName expr) = do

245 else

246 else

246 return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes)

247 return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes)

247

248

248−evalContextExpr (Insert relVarName relExpr) = evalContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName ()))

249+evalDatabaseContextExpr (Insert relVarName relExpr) = evalDatabaseContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName ()))

249

250

250−evalContextExpr (Delete relVarName predicate) = do

251+evalDatabaseContextExpr (Delete relVarName predicate) = do

251 context <- get

252 context <- get

252 let updatedRel = evalState (evalRelationalExpr (Restrict (NotPredicate predicate) (RelationVariable relVarName ()))) (RelationalExprStateElems context)

253 let updatedRel = evalState (evalRelationalExpr (Restrict (NotPredicate predicate) (RelationVariable relVarName ()))) (RelationalExprStateElems context)

253 case updatedRel of

254 case updatedRel of

@@ -255,7 +256,7 @@ evalContextExpr (Delete relVarName predicate) = do

255 Right rel -> setRelVar relVarName rel

256 Right rel -> setRelVar relVarName rel

256

257

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

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

258−evalContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do

259+evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do

259 context <- get

260 context <- get

260 let relVarTable = relationVariables context

261 let relVarTable = relationVariables context

261 case M.lookup relVarName relVarTable of

262 case M.lookup relVarName relVarTable of

@@ -274,7 +275,7 @@ evalContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do

274 updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion

275 updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion

275 union updatedPortion unrestrictedPortion

276 union updatedPortion unrestrictedPortion

276

277

277−evalContextExpr (AddInclusionDependency newDepName newDep) = do

278+evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do

278 currContext <- get

279 currContext <- get

279 let currDeps = inclusionDependencies currContext

280 let currDeps = inclusionDependencies currContext

280 newDeps = M.insert newDepName newDep currDeps

281 newDeps = M.insert newDepName newDep currDeps

@@ -288,7 +289,7 @@ evalContextExpr (AddInclusionDependency newDepName newDep) = do

288 put potentialContext

289 put potentialContext

289 return Nothing

290 return Nothing

290

291

291−evalContextExpr (RemoveInclusionDependency depName) = do

292+evalDatabaseContextExpr (RemoveInclusionDependency depName) = do

292 currContext <- get

293 currContext <- get

293 let currDeps = inclusionDependencies currContext

294 let currDeps = inclusionDependencies currContext

294 newDeps = M.delete depName currDeps

295 newDeps = M.delete depName currDeps

@@ -299,7 +300,7 @@ evalContextExpr (RemoveInclusionDependency depName) = do

299 return Nothing

300 return Nothing

300

301

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

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

302−evalContextExpr (AddNotification notName triggerExpr resultExpr) = do

303+evalDatabaseContextExpr (AddNotification notName triggerExpr resultExpr) = do

303 currentContext <- get

304 currentContext <- get

304 let nots = notifications currentContext

305 let nots = notifications currentContext

305 if M.member notName nots then

306 if M.member notName nots then

@@ -311,7 +312,7 @@ evalContextExpr (AddNotification notName triggerExpr resultExpr) = do

311 put $ currentContext { notifications = newNotifications }

312 put $ currentContext { notifications = newNotifications }

312 return Nothing

313 return Nothing

313

314

314−evalContextExpr (RemoveNotification notName) = do

315+evalDatabaseContextExpr (RemoveNotification notName) = do

315 currentContext <- get

316 currentContext <- get

316 let nots = notifications currentContext

317 let nots = notifications currentContext

317 if M.notMember notName nots then

318 if M.notMember notName nots then

@@ -323,7 +324,7 @@ evalContextExpr (RemoveNotification notName) = do

323

324

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

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

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

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

326−evalContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

327+evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

327 currentContext <- get

328 currentContext <- get

328 let oldTypes = typeConstructorMapping currentContext

329 let oldTypes = typeConstructorMapping currentContext

329 tConsName = TCD.name tConsDef

330 tConsName = TCD.name tConsDef

@@ -341,7 +342,7 @@ evalContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

341 pure Nothing

342 pure Nothing

342

343

343-- | 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.

344-- | 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.

344−evalContextExpr (RemoveTypeConstructor tConsName) = do

345+evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do

345 currentContext <- get

346 currentContext <- get

346 let oldTypes = typeConstructorMapping currentContext

347 let oldTypes = typeConstructorMapping currentContext

347 if findTypeConstructor tConsName oldTypes == Nothing then

348 if findTypeConstructor tConsName oldTypes == Nothing then

@@ -351,15 +352,15 @@ evalContextExpr (RemoveTypeConstructor tConsName) = do

351 put $ currentContext { typeConstructorMapping = newTypes }

352 put $ currentContext { typeConstructorMapping = newTypes }

352 pure Nothing

353 pure Nothing

353

354

354−evalContextExpr (MultipleExpr exprs) = do

355+evalDatabaseContextExpr (MultipleExpr exprs) = do

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

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

356− evald <- forM exprs evalContextExpr

357+ evald <- forM exprs evalDatabaseContextExpr

357 --some lifting magic needed here

358 --some lifting magic needed here

358 case catMaybes evald of

359 case catMaybes evald of

359 [] -> return $ Nothing

360 [] -> return $ Nothing

360 err:_ -> return $ Just err

361 err:_ -> return $ Just err

361

362

362−evalContextExpr (RemoveAtomFunction funcName) = do

363+evalDatabaseContextExpr (RemoveAtomFunction funcName) = do

363 currentContext <- get

364 currentContext <- get

364 let atomFuncs = atomFunctions currentContext

365 let atomFuncs = atomFunctions currentContext

365 dudFunc = emptyAtomFunction funcName -- just for lookup in the hashset

366 dudFunc = emptyAtomFunction funcName -- just for lookup in the hashset

@@ -370,10 +371,11 @@ evalContextExpr (RemoveAtomFunction funcName) = do

370 else

371 else

371 pure (Just (FunctionNameNotInUseError funcName))

372 pure (Just (FunctionNameNotInUseError funcName))

372

373

373−evalContextExpr (RemoveDatabaseContextFunction funcName) = do

374+evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do

374 context <- get

375 context <- get

375 let dudFunc = emptyDatabaseContextFunction funcName

376 let dudFunc = emptyDatabaseContextFunction funcName

376 dbcFuncs = dbcFunctions context

377 dbcFuncs = dbcFunctions context

378+ names = HS.map dbcFuncName dbcFuncs

377 if HS.member dudFunc dbcFuncs then do

379 if HS.member dudFunc dbcFuncs then do

378 let updatedFuncs = HS.delete dudFunc dbcFuncs

380 let updatedFuncs = HS.delete dudFunc dbcFuncs

379 put (context { dbcFunctions = updatedFuncs })

381 put (context { dbcFunctions = updatedFuncs })

@@ -381,37 +383,38 @@ evalContextExpr (RemoveDatabaseContextFunction funcName) = do

381 else

383 else

382 pure (Just (FunctionNameNotInUseError funcName))

384 pure (Just (FunctionNameNotInUseError funcName))

383

385

384−evalContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

386+evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

385 context <- get

387 context <- get

386 --resolve atom arguments

388 --resolve atom arguments

387 let relExprState = mkRelationalExprState context

389 let relExprState = mkRelationalExprState context

388− atomTypes = map (\atomExpr -> evalState (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs

390+ eAtomTypes = map (\atomExpr -> evalState (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs

389 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

391 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

390 case eFunc of

392 case eFunc of

391 Left err -> pure (Just err)

393 Left err -> pure (Just err)

392 Right func -> do

394 Right func -> do

393 let expectedArgCount = length (dbcFuncType func)

395 let expectedArgCount = length (dbcFuncType func)

394− actualArgCount = length atomTypes

396+ actualArgCount = length atomArgExprs

395− safeInit [_] = []

396− safeInit [] = [] -- different behavior from normal init

397− safeInit (_:xs) = safeInit xs

398 if expectedArgCount /= actualArgCount then

397 if expectedArgCount /= actualArgCount then

399 pure (Just (FunctionArgumentCountMismatch expectedArgCount actualArgCount))

398 pure (Just (FunctionArgumentCountMismatch expectedArgCount actualArgCount))

400 else do

399 else do

401−

400+ --check that the atom types are valid

401+ case lefts eAtomTypes of

402+ _:_ -> pure (Just (someErrors (lefts eAtomTypes)))

403+ [] -> do

404+ let atomTypes = rights eAtomTypes

402− let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of

405+ let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of

403− Left err -> Just err

406+ Left err -> Just err

404− Right _ -> Nothing) (safeInit (zip (dbcFuncType func) atomTypes))

407+ Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)

405− typeErrors = catMaybes mValidTypes

408+ typeErrors = catMaybes mValidTypes

406− eAtomArgs = map (\arg -> evalState (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs

409+ eAtomArgs = map (\arg -> evalState (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs

407− if length (lefts eAtomArgs) > 1 then

410+ if length (lefts eAtomArgs) > 1 then

408− pure (Just (MultipleErrors (lefts eAtomArgs)))

411+ pure (Just (someErrors (lefts eAtomArgs)))

409− else if length typeErrors > 1 then

412+ else if length typeErrors > 0 then

410− pure (Just (MultipleErrors typeErrors))

413+ pure (Just (someErrors typeErrors))

411− else do

414+ else do

412− let newContext = evalDatabaseContextFunction func (rights eAtomArgs) context

415+ let newContext = evalDatabaseContextFunction func (rights eAtomArgs) context

413− put newContext

416+ put newContext

414− pure Nothing

417+ pure Nothing

415

418

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

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

417evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = do

420evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = do

src/lib/ProjectM36/ScriptSession.hs+1

@@ -106,6 +106,7 @@ initScriptSession ghcPkgPaths = do

106 setContext (map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn))

107 ["Prelude",

108 "Data.Map",

109+ "Data.Either",

109 "Control.Monad.State",

110 "Control.Monad.State",

110 "ProjectM36.Base",

111 "ProjectM36.Base",

111 "ProjectM36.Relation",

112 "ProjectM36.Relation",

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

@@ -179,7 +179,7 @@ applyStaticDatabaseOptimization (MultipleExpr exprs) = do

179 where

180 substateRunner = forM exprs $ \expr -> do

181 --a previous expression 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

182− _ <- evalContextExpr expr

182+ _ <- evalDatabaseContextExpr expr

183 applyStaticDatabaseOptimization expr

184 --this error handling could be improved with some lifting presumably

185 --restore original context

test/IsomorphicSchema.hs+1−1

@@ -92,7 +92,7 @@ testIsoRestrict = TestCase $ do

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

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

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

95− let postInsertContext = execState (evalContextExpr schemaBInsertExpr') (stateContext schemaA)

95+ let postInsertContext = execState (evalDatabaseContextExpr schemaBInsertExpr') (stateContext schemaA)

96 expectedRel = evalState (evalRelationalExpr (Union (RelationVariable "boss" ()) (RelationVariable "nonboss" ()))) (mkRelationalExprState postInsertContext)

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

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

test/TransactionGraph/Merge.hs+1−1

@@ -113,7 +113,7 @@ testSubGraphToFirstAncestorMoreTransactions = TestCase $ do

113

114 -- add another relvar to branchB

115 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"

116− updatedBranchBContext <- case runState (evalContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (concreteDatabaseContext branchBTrans) of

116+ updatedBranchBContext <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (concreteDatabaseContext branchBTrans) of

117 (Just err, _) -> assertFailure (show err) >> undefined

118 (Nothing, context) -> pure context

119 (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph

test/TutorialD/Interpreter/DatabaseContextFunctionScript.hsnew file+59

@@ -0,0 +1,59 @@

1+import TutorialD.Interpreter.TestBase

2+import System.Exit

3+import Test.HUnit

4+import ProjectM36.Client

5+import ProjectM36.Relation

6+import qualified Data.Text as T

8+main :: IO ()

9+main = do

10+ tcounts <- runTestTT (TestList [testBasicDBCFunction,

11+ testErrorDBCFunction,

12+ testDBCFunctionWithAtomArguments

13+ ])

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

15+

16+{-

17+adddatabasecontextfunction "addtruerv" DatabaseContext -> DatabaseContext """(\[] ctx -> execState (evalContextExpr (Assign "true2" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""

18+-}

19+testBasicDBCFunction :: Test

20+testBasicDBCFunction = TestCase $ do

21+ (sess, conn) <- dateExamplesConnection emptyNotificationCallback

22+ let addfunc = "adddatabasecontextfunction \"addTrue2\" DatabaseContext -> DatabaseContext \"\"\"(\\[] ctx -> execState (evalContextExpr (Assign \"true2\" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext\"\"\""

23+ executeTutorialD sess conn addfunc

24+ executeTutorialD sess conn "execute addTrue2()"

25+ let true2Expr = RelationVariable "true2" ()

26+ result <- executeRelationalExpr sess conn true2Expr

27+ assertEqual "simple atom function equality" (Right relationTrue) result

28+

29+testErrorDBCFunction :: Test

30+testErrorDBCFunction = TestCase $ do

31+ -- throw an error, make sure it is caught- it might not be caught, for example, if the function is not forced

32+ (sess, conn) <- dateExamplesConnection emptyNotificationCallback

33+ let addfunc = "adddatabasecontextfunction \"bomb\" DatabaseContext -> DatabaseContext \"\"\"(\\[] _ -> error \"boom\") :: [Atom] -> DatabaseContext -> DatabaseContext\"\"\""

34+ executeTutorialD sess conn addfunc

35+ expectTutorialDErr sess conn (\err -> "UnhandledExceptionError" `T.isPrefixOf` err) "execute bomb()"

36+

37+{-

38+adddatabasecontextfunction "multiArgFunc" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> execState (evalContextExpr (Assign "person" (MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", NakedAtomExpr name), ("age", NakedAtomExpr age)])]))) ctx)"""

39+-}

40+testDBCFunctionWithAtomArguments :: Test

41+testDBCFunctionWithAtomArguments = TestCase $ do

42+ --test function with creation of a relvar with some arguments

43+ (sess, conn) <- dateExamplesConnection emptyNotificationCallback

44+ let addfunc = "adddatabasecontextfunction \"multiArgFunc\" Int -> Text -> DatabaseContext -> DatabaseContext \"\"\"(\\(age:name:_) ctx -> execState (evalContextExpr (Assign \"person\" (MakeRelationFromExprs Nothing [TupleExpr (fromList [(\"name\", NakedAtomExpr name), (\"age\", NakedAtomExpr age)])]))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext\"\"\""

45+ executeTutorialD sess conn addfunc

46+ executeTutorialD sess conn "execute multiArgFunc(30,\"Steve\")"

47+ result <- executeRelationalExpr sess conn (RelationVariable "person" ())

48+ let expectedPerson = mkRelationFromList (attributesFromList [Attribute "name" TextAtomType,

49+ Attribute "age" IntAtomType]) [

50+ [TextAtom "Steve", IntAtom 30]]

51+ assertEqual "person relation" expectedPerson result

52+ expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")"

53+

54+{-

55+adddatabasecontextfunction "addperson" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> let newrel = MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", name),("age",age))]] in if isRight (runState (executeRelationalExpr (RelationVariable "person" ()) ctx)) then execState (executeContextExpr (Insert "person" newrel)) ctx else execState (executeContextExpr (Assign "person" newrel)) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""

56+-}

57+

58+f :: [Atom] -> DatabaseContext -> DatabaseContext

59+f = \(age:name:_) ctx -> let newrel = MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", name),("age",age))]] in if isRight (runState (executeRelationalExpr (RelationVariable "person" ()))ctx) then execState (executeContextExpr (Insert "person" newrel)) ctx else execState (executeContextExpr (Assign "person" newrel)) ctx

test/TutorialD/Interpreter/TestBase.hs+3−5

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

1module TutorialD.Interpreter.TestBase where

2import ProjectM36.Client

3−import ProjectM36.Error

4import TutorialD.Interpreter

3import TutorialD.Interpreter

5import TutorialD.Interpreter.Base

4import TutorialD.Interpreter.Base

6import qualified ProjectM36.Base as Base

5import qualified ProjectM36.Base as Base

@@ -40,8 +39,8 @@ executeTutorialD sessionId conn tutd = case parseTutorialD tutd of

40 DisplayErrorResult err -> assertFailure (show err)

39 DisplayErrorResult err -> assertFailure (show err)

41 QuietSuccessResult -> pure ()

40 QuietSuccessResult -> pure ()

43−expectTutorialDErr :: SessionId -> Connection -> RelationalError -> Text -> IO ()

42+expectTutorialDErr :: SessionId -> Connection -> (Text -> Bool) -> Text -> IO ()

44−expectTutorialDErr sessionId conn expectedErr tutd = case parseTutorialD tutd of

43+expectTutorialDErr sessionId conn matchFunc tutd = case parseTutorialD tutd of

45 Left err -> assertFailure (show tutd ++ ": " ++ show err)

44 Left err -> assertFailure (show tutd ++ ": " ++ show err)

46 Right parsed -> do

45 Right parsed -> do

47 result <- evalTutorialD sessionId conn UnsafeEvaluation parsed

46 result <- evalTutorialD sessionId conn UnsafeEvaluation parsed

@@ -51,9 +50,8 @@ expectTutorialDErr sessionId conn expectedErr tutd = case parseTutorialD tutd of

51 DisplayIOResult _ -> assertFailure "displayIO?"

50 DisplayIOResult _ -> assertFailure "displayIO?"

52 DisplayRelationResult _ -> assertFailure "displayrelation?"

51 DisplayRelationResult _ -> assertFailure "displayrelation?"

53 DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?"

52 DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?"

54− DisplayErrorResult err -> assertEqual "match error" (pack (show expectedErr)) err

53+ DisplayErrorResult err -> assertBool ("match error on: " ++ unpack err) (matchFunc err)

55 QuietSuccessResult -> pure ()

54 QuietSuccessResult -> pure ()

56−

58maybeFail :: (Show a) => Maybe a -> IO ()

56maybeFail :: (Show a) => Maybe a -> IO ()

59maybeFail (Just err) = assertFailure (show err)

57maybeFail (Just err) = assertFailure (show err)