a0e6f44 · project-m36 · git.iko.soy

git.iko.soy/project-m36

polish up database context function work

-documentation -tests -there should likely be a separate module which is imported for database context functions which exports a variety of convenience functions

commita0e6f44ce65fcd8a16ecc9b489bfb4a5fd443324 authorAgentM <agentm@themactionfaction.com> dateThu 6 Apr 2017, 22:49 (10 years ago) parentaee15b2

14 files changed+271−103

compare with master

unifiedsplit

docs/database_context_functions.markdown+117 project-m36.cabal+11 src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+4−3 src/bin/benchmark/bigrel.hs+1−1 src/lib/ProjectM36/Base.hs+26−48 src/lib/ProjectM36/Client.hs+4−4 src/lib/ProjectM36/IsomorphicSchema.hs+1−1 src/lib/ProjectM36/RelationalExpression.hs+41−38 src/lib/ProjectM36/ScriptSession.hs+1 src/lib/ProjectM36/StaticOptimizer.hs+1−1 test/IsomorphicSchema.hs+1−1 test/TransactionGraph/Merge.hs+1−1 test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs+59 test/TutorialD/Interpreter/TestBase.hs+3−5

docs/database_context_functions.markdownnew file+117

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

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

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

286286

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+

287298Test-Suite test-relation

288299 Default-Language: Haskell2010

289300 Default-Extensions: OverloadedStrings

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

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

1111import ProjectM36.StaticOptimizer

1212import qualified ProjectM36.Error as PM36E

1313import ProjectM36.Error

14−import ProjectM36.RelationalExpression

14+import qualified ProjectM36.RelationalExpression as RE

1515import ProjectM36.Key

1616import ProjectM36.FunctionalDependency

1717import Data.Monoid

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

3333 addTypeConstructorP,

3434 removeTypeConstructorP,

3535 executeDatabaseContextFunctionP,

36+ removeDatabaseContextFunctionP,

3637 nothingP]

3738

3839nothingP :: Parser DatabaseContextExpr

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

190191 funcName <- identifier

191192 args <- parens (sepBy atomExprP comma)

192193 pure (ExecuteDatabaseContextFunction funcName args)

193−

194+

194195databaseExprOpP :: Parser DatabaseContextExpr

195196databaseExprOpP = multipleDatabaseContextExprP

196197

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

198199evalDatabaseContextExpr useOptimizer context expr = do

199200 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

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

202203 (Just err, _) -> Left err

203204

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

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

5959 putStrLn "Done."

6060 else do

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

62− context = execState (evalContextExpr setx) dateExamples

62+ context = execState (evalDatabaseContextExpr setx) dateExamples

6363 interpreted = interpretDatabaseContextExpr context tutd

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

6565 --displayOpResult plan

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

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

8989type AttributeName = StringType

9090

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

9393

9494instance Hashable Attribute where

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

9696

97−instance NFData Attribute where rnf = genericRnf

98−

99−instance Binary Attribute

100−

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

10298type Attributes = V.Vector Attribute

10399

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

210206 NotEquals (RelationalExprBase a) (RelationalExprBase a) |

211207 Extend (ExtendTupleExprBase a) (RelationalExprBase a)

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

214212

215−instance Binary RelationalExpr

216−

217213type NotificationName = StringType

218214type Notifications = M.Map NotificationName Notification

219215

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

222218 changeExpr :: RelationalExpr,

223219 reportExpr :: RelationalExpr

224220 }

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

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

226222

227223type TypeVarName = StringType

228224

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

248244type AtomTypeName = StringType

249245

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

252248

253249type DataConstructorDefs = [DataConstructorDef]

254250

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

286282 dbcFunctions :: DatabaseContextFunctions,

287283 notifications :: Notifications,

288284 typeConstructorMapping :: TypeConstructorMapping

289− }

285+ } deriving (NFData, Generic)

290286

291287type IncDepName = StringType

292288

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

295291

296292instance Binary InclusionDependency

297293

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

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

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

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

346− deriving (Show, Eq, Generic)

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

347343

348344instance Binary RestrictionPredicateExpr

349345

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

399395 FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |

400396 RelationAtomExpr (RelationalExprBase a) |

401397 ConstructedAtomExpr DataConstructorName [AtomExprBase a] a

402− deriving (Eq,Show,Generic)

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

403399

404400instance Binary AtomExpr

405401

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

407403data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)

408− deriving (Show, Eq, Generic)

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

409405

410406type ExtendTupleExpr = ExtendTupleExprBase ()

411407

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

421417type AtomFunctionBodyType = [Atom] -> Atom

422418

423419data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType

420+

421+instance NFData AtomFunctionBody where

422+ rnf (AtomFunctionBody mScript _) = rnf mScript

424423

425424instance Show AtomFunctionBody where

426425 show (AtomFunctionBody mScript _) = case mScript of

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

432431 atomFuncName :: AtomFunctionName,

433432 atomFuncType :: [AtomType],

434433 atomFuncBody :: AtomFunctionBody

435− }

434+ } deriving (Generic, NFData)

436435

437436instance Hashable AtomFunction where

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

439438

440439instance Eq AtomFunction where

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

442− (AtomFunctionBody mScript2 _) = atomFuncBody f2 in

443− if atomFuncName f1 == atomFuncName f2 then

444− if isJust mScript1 then

445− if mScript1 == mScript2 then

446− True

447− else

448− False

449− else

450− True

451− else

452− False

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

453441

454442instance Show AtomFunction where

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

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

462450 InvertedAttributeNames (S.Set AttributeName) |

463451 UnionAttributeNames AttributeNames AttributeNames |

464452 IntersectAttributeNames AttributeNames AttributeNames

465− deriving (Eq, Show, Generic)

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

466454

467−instance Binary AttributeNames

468−

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

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

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

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

476462

477463data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |

478464 NakedAttributeExpr Attribute

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

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

480466

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

482− deriving (Eq, Show, Generic)

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

483469

484−instance Binary TupleExpr

470+instance Binary TupleExpr

485471

486472type TupleExpr = TupleExprBase ()

487473

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

500486

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

502488

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

504493

505494data DatabaseContextFunction = DatabaseContextFunction {

506495 dbcFuncName :: DatabaseContextFunctionName,

507496 dbcFuncType :: [AtomType],

508497 dbcFuncBody :: DatabaseContextFunctionBody

509− }

498+ } deriving (Generic, NFData)

510499

511500type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction

512501

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

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

515504

516505instance Eq DatabaseContextFunction where

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

518− (DatabaseContextFunctionBody mScript2 _) = dbcFuncBody f2 in

519− if dbcFuncName f1 == dbcFuncName f2 then

520− if isJust mScript1 then

521− if mScript1 == mScript2 then

522− True

523− else

524− False

525− else

526− True

527− else

528− False

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

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

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

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

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

22module ProjectM36.Client

33 (ConnectionInfo(..),

44 Connection(..),

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

392392close (InProcessConnection conf) = do

393393 atomically $ do

394394 let sessions = ipSessions conf

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

395+ STMMap.deleteAll sessions

396396 pure ()

397397 closeLocalNode (ipLocalNode conf)

398398 closeTransport (ipTransport conf)

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

533533 Schema.processDatabaseContextExprInSchema schema expr

534534 case expr' of

535535 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

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

538− (Nothing, context') -> do

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

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

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

541541 newSchemas = Schemas context' newSubschemas

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

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

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

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

329329 in

330− case runState (evalContextExpr incDepExprs) context of

330+ case runState (evalDatabaseContextExpr incDepExprs) context of

331331 (Just err, _) -> Left err

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

333333 where

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

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

2626

2727import GHC

2828import GHC.Paths

29+import Debug.Trace

2930

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

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

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

209210 put newContext

210211 return Nothing

211212

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

213−evalContextExpr NoOperation = pure Nothing

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

214+evalDatabaseContextExpr NoOperation = pure Nothing

214215

215−evalContextExpr (Define relVarName attrExprs) = do

216+evalDatabaseContextExpr (Define relVarName attrExprs) = do

216217 relvars <- liftM relationVariables get

217218 tConss <- liftM typeConstructorMapping get

218219 let eAttrs = map (evalAttrExpr tConss) attrExprs

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

225226 attrs = A.attributesFromList (rights eAttrs)

226227 emptyRelation = Relation attrs emptyTupleSet

227228

228−evalContextExpr (Undefine relVarName) = do

229+evalDatabaseContextExpr (Undefine relVarName) = do

229230 deleteRelVar relVarName

230231

231−evalContextExpr (Assign relVarName expr) = do

232+evalDatabaseContextExpr (Assign relVarName expr) = do

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

233234 context <- get

234235 let existingRelVar = M.lookup relVarName relVarTable

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

245246 else

246247 return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes)

247248

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

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

249250

250−evalContextExpr (Delete relVarName predicate) = do

251+evalDatabaseContextExpr (Delete relVarName predicate) = do

251252 context <- get

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

253254 case updatedRel of

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

255256 Right rel -> setRelVar relVarName rel

256257

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

258−evalContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do

259+evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do

259260 context <- get

260261 let relVarTable = relationVariables context

261262 case M.lookup relVarName relVarTable of

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

274275 updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion

275276 union updatedPortion unrestrictedPortion

276277

277−evalContextExpr (AddInclusionDependency newDepName newDep) = do

278+evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do

278279 currContext <- get

279280 let currDeps = inclusionDependencies currContext

280281 newDeps = M.insert newDepName newDep currDeps

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

288289 put potentialContext

289290 return Nothing

290291

291−evalContextExpr (RemoveInclusionDependency depName) = do

292+evalDatabaseContextExpr (RemoveInclusionDependency depName) = do

292293 currContext <- get

293294 let currDeps = inclusionDependencies currContext

294295 newDeps = M.delete depName currDeps

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

299300 return Nothing

300301

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

303304 currentContext <- get

304305 let nots = notifications currentContext

305306 if M.member notName nots then

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

311312 put $ currentContext { notifications = newNotifications }

312313 return Nothing

313314

314−evalContextExpr (RemoveNotification notName) = do

315+evalDatabaseContextExpr (RemoveNotification notName) = do

315316 currentContext <- get

316317 let nots = notifications currentContext

317318 if M.notMember notName nots then

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

323324

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

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

326−evalContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

327+evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

327328 currentContext <- get

328329 let oldTypes = typeConstructorMapping currentContext

329330 tConsName = TCD.name tConsDef

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

341342 pure Nothing

342343

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

345346 currentContext <- get

346347 let oldTypes = typeConstructorMapping currentContext

347348 if findTypeConstructor tConsName oldTypes == Nothing then

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

351352 put $ currentContext { typeConstructorMapping = newTypes }

352353 pure Nothing

353354

354−evalContextExpr (MultipleExpr exprs) = do

355+evalDatabaseContextExpr (MultipleExpr exprs) = do

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

356− evald <- forM exprs evalContextExpr

357+ evald <- forM exprs evalDatabaseContextExpr

357358 --some lifting magic needed here

358359 case catMaybes evald of

359360 [] -> return $ Nothing

360361 err:_ -> return $ Just err

361362

362−evalContextExpr (RemoveAtomFunction funcName) = do

363+evalDatabaseContextExpr (RemoveAtomFunction funcName) = do

363364 currentContext <- get

364365 let atomFuncs = atomFunctions currentContext

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

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

370371 else

371372 pure (Just (FunctionNameNotInUseError funcName))

372373

373−evalContextExpr (RemoveDatabaseContextFunction funcName) = do

374+evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do

374375 context <- get

375376 let dudFunc = emptyDatabaseContextFunction funcName

376377 dbcFuncs = dbcFunctions context

378+ names = HS.map dbcFuncName dbcFuncs

377379 if HS.member dudFunc dbcFuncs then do

378380 let updatedFuncs = HS.delete dudFunc dbcFuncs

379381 put (context { dbcFunctions = updatedFuncs })

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

381383 else

382384 pure (Just (FunctionNameNotInUseError funcName))

383385

384−evalContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

386+evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

385387 context <- get

386388 --resolve atom arguments

387389 let relExprState = mkRelationalExprState context

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

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

389391 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

390392 case eFunc of

391393 Left err -> pure (Just err)

392394 Right func -> do

393395 let expectedArgCount = length (dbcFuncType func)

394− actualArgCount = length atomTypes

395− safeInit [_] = []

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

397− safeInit (_:xs) = safeInit xs

396+ actualArgCount = length atomArgExprs

398397 if expectedArgCount /= actualArgCount then

399398 pure (Just (FunctionArgumentCountMismatch expectedArgCount actualArgCount))

400399 else do

401−

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

403− Left err -> Just err

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

405− typeErrors = catMaybes mValidTypes

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

407− if length (lefts eAtomArgs) > 1 then

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

409− else if length typeErrors > 1 then

410− pure (Just (MultipleErrors typeErrors))

411− else do

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

413− put newContext

414− pure Nothing

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

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

406+ Left err -> Just err

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

408+ typeErrors = catMaybes mValidTypes

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

410+ if length (lefts eAtomArgs) > 1 then

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

412+ else if length typeErrors > 0 then

413+ pure (Just (someErrors typeErrors))

414+ else do

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

416+ put newContext

417+ pure Nothing

415418

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

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

src/lib/ProjectM36/ScriptSession.hs+1

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

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

107107 ["Prelude",

108108 "Data.Map",

109+ "Data.Either",

109110 "Control.Monad.State",

110111 "ProjectM36.Base",

111112 "ProjectM36.Relation",

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

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

179179 where

180180 substateRunner = forM exprs $ \expr -> do

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

183183 applyStaticDatabaseOptimization expr

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

185185 --restore original context

test/IsomorphicSchema.hs+1−1

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

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

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

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

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

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

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

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

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

test/TransactionGraph/Merge.hs+1−1

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

113113

114114 -- add another relvar to branchB

115115 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

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

118118 (Nothing, context) -> pure context

119119 (_, 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 @@

11module TutorialD.Interpreter.TestBase where

22import ProjectM36.Client

3−import ProjectM36.Error

43import TutorialD.Interpreter

54import TutorialD.Interpreter.Base

65import qualified ProjectM36.Base as Base

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

4039 DisplayErrorResult err -> assertFailure (show err)

4140 QuietSuccessResult -> pure ()

4241

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

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

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

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

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

4645 Right parsed -> do

4746 result <- evalTutorialD sessionId conn UnsafeEvaluation parsed

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

5150 DisplayIOResult _ -> assertFailure "displayIO?"

5251 DisplayRelationResult _ -> assertFailure "displayrelation?"

5352 DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?"

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

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

5554 QuietSuccessResult -> pure ()

56−

5755

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

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