37b059d · project-m36 · git.iko.soy

git.iko.soy/project-m36

Merge branch '197_load_dynamic_modules'

commit37b059db8f2223b3d6f6d71bc8f7405a64859c3c authorAgentM <agentm@themactionfaction.com> dateTue 15 May 2018, 14:50 (8 years ago) parent2e494d2 878ba87

18 files changed+308−17

compare with master

unifiedsplit

docs/atomfunctions.markdown+30−1 docs/database_context_functions.markdown+51−1 examples/DynamicAtomFunctions.hs+12 examples/DynamicDatabaseContextFunctions.hs+26 project-m36.cabal+4−4 src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs+14−2 src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+22 src/lib/ProjectM36/AtomFunction.hs+18−1 src/lib/ProjectM36/AtomType.hs+4−2 src/lib/ProjectM36/Base.hs+6−2 src/lib/ProjectM36/Client.hs+30−2 src/lib/ProjectM36/DatabaseContextFunction.hs+20−1 src/lib/ProjectM36/Error.hs+1 src/lib/ProjectM36/RelationalExpression.hs+14−1 src/lib/ProjectM36/ScriptSession.hs+40 src/lib/ProjectM36/Server.hs+2 src/lib/ProjectM36/Server/EntryPoints.hs+10 src/lib/ProjectM36/Server/RemoteCallTypes.hs+4

docs/atomfunctions.markdown+30−1

@@ -6,7 +6,7 @@ While Project:M36 includes a set of basic function which operate on relational v

77Other DBMSes also include this feature by way of stored functions such as with PL/pgsql, T-SQL, or PL/SQL.

9−Project:M36 allows users to implement strongly-typed and pure atom functions in the Haskell language at runtime. This facility makes use of GHC, the Haskell compiler, as a runtime service.

9+Project:M36 allows users to implement strongly-typed and pure atom functions in the Haskell language at runtime. This facility makes use of GHC, the Haskell compiler, as a runtime service. Alternatively, Haskell-based atom functions can be pre-compiled and loaded at runtime.

1010

1111## Atom Function Example

1212

@@ -41,6 +41,35 @@ Project:M36 also supports polymorphic types when used with atom functions. Here

4141addatomfunction "idTest" a -> Either AtomFunctionError a "(\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom"

4242```

4343

44+## Pre-compiled Atom Functions

45+

46+Compiling atom functions at runtime can incur a performance cost. To mitigate this, atom functions can be compiled by GHC to object files and then loaded into the Project:M36 server. Let's look at an [example](https://github.com/agentm/project-m36/):

47+

48+```haskell

49+module DynamicAtomFunctions where

50+import ProjectM36.Base

51+

52+someAtomFunctions :: [AtomFunction]

53+someAtomFunctions = [AtomFunction{

54+ atomFuncName = "constTrue",

55+ atomFuncType = [TypeVariableType "a", BoolAtomType],

56+ atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure (BoolAtom True))}]

57+```

58+

59+Any function inside any module which returns a list of `AtomFunction`s can be used to load more atom functions. First, create the Haskell object file:

60+

61+`cabal exec ghc -- examples/DynamicAtomFunctions.hs -package project-m36`

62+

63+Use cabal or stack to invoke ghc so that the project-m36 installed package will be found.

64+

65+Finally, connect to your Project:M36 database using the `tutd` client and run:

66+

67+`TutorialD (master/main): loadatomfunctions "DynamicAtomFunctions" "someFunctions" "examples/DynamicAtomFunctions.o"`

68+

69+If you see an error such as "unknown symbol", the version of the "project-m36" library installed in your sandbox is different from that with which you linked the object file. Make sure that the same versions are used in linking the server and object file.

70+

71+The atom function is now loaded and ready-to-use. Note, however, that the function must be added every time the project-m36-server starts. This will probably be improved in a future release.

72+

4473## Differences when compared to other DBMSes

4574

4675Project:M36 enforces strongly-typed atom functions. Specifically, atom functions must be pure (free of any side effects) and cannot operate on any variables other than the atoms passed in. This certainly sets stricter limits on what can be accomplished in an atom function when compared to stored functions in other DBMS products. For example, an atom function in Project:M36 would never be able to retrieve stock information from an external website because such a function cannot be pure and thus would be rejected by the atom function compiler. This restriction maintains the mathematical cohesiveness of the database and allows the DBMS to make performance-enhancing inferences it would not otherwise be able to make.

docs/database_context_functions.markdown+51−1

@@ -6,7 +6,7 @@ While "atom functions" operate on individual values and return new values (atoms

77Other 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.

9+In order to use compile functions at runtime in Project:M36, be sure to build your own Project:M36 library so that the optional scripting is enabled. Alternatively, precompiled database context functions can be loaded from object files.

1010

1111## Database Context Function Types

1212

@@ -112,6 +112,56 @@ executeDatabaseContextExpr sessionId dbconn (ExecuteDatabaseContextFunction func

112112```

113113from the same module.

114114

115+## Loading Precompiled Modules

116+

117+Database context functions compiled with GHC to object files can be loaded at runtime. Let's walk through an example:

118+

119+```haskell

120+module DynamicDatabaseContextFunctions where

121+import ProjectM36.Base

122+import ProjectM36.Relation

123+import ProjectM36.DatabaseContextFunctionError

124+import qualified ProjectM36.Attribute as A

125+

126+import qualified Data.Map as M

127+

128+

129+someDBCFunctions :: [DatabaseContextFunction]

130+someDBCFunctions = [DatabaseContextFunction {

131+ dbcFuncName = "addtestrel",

132+ dbcFuncType = [],

133+ dbcFuncBody = DatabaseContextFunctionBody Nothing addTestRel

134+ }]

135+ where

136+ addTestRel _ ctx = do

137+ let attrs = A.attributesFromList [Attribute "word" TextAtomType]

138+ eRel = mkRelationFromList attrs [[TextAtom "nice"]]

139+ case eRel of

140+ Left err -> Left (DatabaseContextFunctionUserError (show err))

141+ Right testRel ->

142+ pure $ ctx { relationVariables = M.insert "testRel" testRel (relationVariables ctx) }

143+```

144+

145+The function returns a list of `DatabaseContextFunction`s (just one in this case). The function adds a relation variable to the current database context.

146+

147+Compile it with GHC:

148+

149+```

150+cabal exec ghc -- examples/DynamicDatabaseContextFunctions.hs -package project-m36

151+```

152+

153+or invoked GHC via stack.

154+

155+Finally, connect to your database with `tutd` and load the module:

156+

157+```

158+TutorialD (master/main): loaddatabasecontextfunctions "DynamicDatabaseContextFunctions" "someDBCFunctions" "examples/DynamicDatabaseContextFunctions.o"

159+```

160+

161+If the load reports an "unknown symbol" error, double check that the installed "project-m36" package is identical to one used to link the Haskell module.

162+

163+Note that such functions do not survive a server restart; this will likely be improved in a future release.

164+

115165## Future Improvements

116166

117167There 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.

examples/DynamicAtomFunctions.hsnew file+12

@@ -0,0 +1,12 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+--compile with `cabal exec ghc -- examples/DynamicAtomFunctions.hs -package project-m36`

3+--load with `loadatomfunctions "DynamicAtomFunctions" "someAtomFunctions" "examples/DynamicAtomFunctions.o"`

5+module DynamicAtomFunctions where

6+import ProjectM36.Base

8+someAtomFunctions :: [AtomFunction]

9+someAtomFunctions = [AtomFunction{

10+ atomFuncName = "constTrue",

11+ atomFuncType = [TypeVariableType "a", BoolAtomType],

12+ atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure (BoolAtom True))}]

examples/DynamicDatabaseContextFunctions.hsnew file+26

@@ -0,0 +1,26 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+--compile with `cabal exec ghc -- examples/DynamicDatabaseContextFunctions.hs -package project-m36`

3+--load with `loaddatabasecontextfunctions "DynamicDatabaseContextFunctions" "someDBCFunctions" "examples/DynamicDatabaseContextFunctions.o"`

4+module DynamicDatabaseContextFunctions where

5+import ProjectM36.Base

6+import ProjectM36.Relation

7+import ProjectM36.DatabaseContextFunctionError

8+import qualified ProjectM36.Attribute as A

10+import qualified Data.Map as M

11+

12+

13+someDBCFunctions :: [DatabaseContextFunction]

14+someDBCFunctions = [DatabaseContextFunction {

15+ dbcFuncName = "addtestrel",

16+ dbcFuncType = [],

17+ dbcFuncBody = DatabaseContextFunctionBody Nothing addTestRel

18+ }]

19+ where

20+ addTestRel _ ctx = do

21+ let attrs = A.attributesFromList [Attribute "word" TextAtomType]

22+ eRel = mkRelationFromList attrs [[TextAtom "nice"]]

23+ case eRel of

24+ Left err -> Left (DatabaseContextFunctionUserError (show err))

25+ Right testRel ->

26+ pure $ ctx { relationVariables = M.insert "testRel" testRel (relationVariables ctx) }

project-m36.cabal+4−4

@@ -152,20 +152,20 @@ Library

152152 ProjectM36.TypeConstructorDef,

153153 ProjectM36.FileLock,

154154 ProjectM36.FSType

155− GHC-Options: -Wall

155+ GHC-Options: -Wall -rdynamic

156156 if os(windows)

157157 Build-Depends: Win32 >= 2.3

158158 Other-Modules: ProjectM36.Win32Handle

159159 else

160160 C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c

161161 Build-Depends: unix

162− CC-Options: -fPIC

162+ CC-Options: -fPIC

163163 Hs-Source-Dirs: ./src/lib

164164 Default-Language: Haskell2010

165165 Default-Extensions: OverloadedStrings, CPP

166166 if impl(ghc>= 8)

167167 build-depends:

168− ghc-boot

168+ ghc-boot, ghci

169169

170170Executable tutd

171171 Build-Depends: base >=4.8 && <5.0,

@@ -225,7 +225,7 @@ Executable tutd

225225 TutorialD.Interpreter.SchemaOperator

226226 main-is: TutorialD/tutd.hs

227227 CC-Options: -fPIC

228− GHC-Options: -Wall

228+ GHC-Options: -Wall -rdynamic

229229 Hs-Source-Dirs: ./src/bin

230230 Default-Language: Haskell2010

231231 Default-Extensions: OverloadedStrings

src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs+14−2

@@ -26,6 +26,18 @@ atomTypeSignatureP :: Parser [TypeConstructor]

2626atomTypeSignatureP = sepBy typeConstructorP arrow

2727

2828dbContextIOExprP :: Parser DatabaseContextIOExpr

29−dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP

30−

29+dbContextIOExprP = addAtomFunctionExprP <|>

30+ addDatabaseContextFunctionExprP <|>

31+ loadAtomFunctionsP <|>

32+ loadDatabaseContextFunctionsP

33+

34+loadAtomFunctionsP :: Parser DatabaseContextIOExpr

35+loadAtomFunctionsP = do

36+ reserved "loadatomfunctions"

37+ LoadAtomFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString

38+

39+loadDatabaseContextFunctionsP :: Parser DatabaseContextIOExpr

40+loadDatabaseContextFunctionsP = do

41+ reserved "loaddatabasecontextfunctions"

42+ LoadDatabaseContextFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString

3143

src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+22

@@ -24,6 +24,8 @@ data RODatabaseContextOperator where

2424 ShowPlan :: DatabaseContextExpr -> RODatabaseContextOperator

2525 ShowTypes :: RODatabaseContextOperator

2626 ShowRelationVariables :: RODatabaseContextOperator

27+ ShowAtomFunctions :: RODatabaseContextOperator

28+ ShowDatabaseContextFunctions :: RODatabaseContextOperator

2729 Quit :: RODatabaseContextOperator

2830 deriving (Show)

2931

@@ -48,6 +50,12 @@ showTypesP = reserved ":showtypes" >> pure ShowTypes

4850showRelationVariables :: Parser RODatabaseContextOperator

4951showRelationVariables = reserved ":showrelvars" >> pure ShowRelationVariables

5052

53+showAtomFunctionsP :: Parser RODatabaseContextOperator

54+showAtomFunctionsP = reserved ":showatomfunctions" >> pure ShowAtomFunctions

55+

56+showDatabaseContextFunctionsP :: Parser RODatabaseContextOperator

57+showDatabaseContextFunctionsP = reserved ":showdatabasecontextfunctions" >> pure ShowDatabaseContextFunctions

58+

5159quitP :: Parser RODatabaseContextOperator

5260quitP = do

5361 reservedOp ":quit"

@@ -71,6 +79,8 @@ roDatabaseContextOperatorP = typeP

7179 <|> showConstraintsP

7280 <|> showPlanP

7381 <|> showTypesP

82+ <|> showAtomFunctionsP

83+ <|> showDatabaseContextFunctionsP

7484 <|> quitP

7585

7686--logically, these read-only operations could happen purely, but not if a remote call is required

@@ -125,6 +135,18 @@ evalRODatabaseContextOp sessionId conn ShowRelationVariables = do

125135 case eRel of

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

127137 Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

138+

139+evalRODatabaseContextOp sessionId conn ShowAtomFunctions = do

140+ eRel <- C.atomFunctionsAsRelation sessionId conn

141+ case eRel of

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

143+ Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

144+

145+evalRODatabaseContextOp sessionId conn ShowDatabaseContextFunctions = do

146+ eRel <- C.databaseContextFunctionsAsRelation sessionId conn

147+ case eRel of

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

149+ Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

128150

129151evalRODatabaseContextOp _ _ Quit = pure QuitResult

130152

src/lib/ProjectM36/AtomFunction.hs+18−1

@@ -1,11 +1,17 @@

11module ProjectM36.AtomFunction where

22import ProjectM36.Base

33import ProjectM36.Error

4+import ProjectM36.Relation

5+import ProjectM36.AtomType

46import ProjectM36.AtomFunctionError

7+import ProjectM36.ScriptSession

58import qualified ProjectM36.Attribute as A

69import qualified Data.HashSet as HS

10+import qualified Data.Text as T

11+

712

813foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

14+--the underscore in the attribute name means that any attributes are acceptable

915foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]

1016

1117atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction

@@ -64,4 +70,15 @@ createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName

6470 argsType ++ [ADTypeConstructor "Either" [

6571 ADTypeConstructor "AtomFunctionError" [],

6672 retType]])

67−

73+

74+loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction])

75+loadAtomFunctions = loadFunction

76+

77+atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation

78+atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

79+ where tups = map atomFuncToTuple (HS.toList funcs)

80+ attrs = A.attributesFromList [Attribute "name" TextAtomType,

81+ Attribute "arguments" TextAtomType]

82+ atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

83+ TextAtom (atomFuncTypeToText aFunc)]

84+ atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))

src/lib/ProjectM36/AtomType.hs+4−2

@@ -252,14 +252,16 @@ prettyAtomType :: AtomType -> T.Text

252252prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"

253253prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))

254254 where

255+ showTypeVars (_, TypeVariableType x) = " " <> x

255256 showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"

256257-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)

257−prettyAtomType (TypeVariableType x) = "?TypeVariableType " <> x <> "?"

258−prettyAtomType (IntervalAtomType tv) = "Interval (" <> prettyAtomType tv <> ")"

258+prettyAtomType (TypeVariableType x) = x

259+prettyAtomType (IntervalAtomType tv) = "Interval " <> prettyAtomType tv

259260prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName

260261 where fullName = (T.pack . show) aType

261262

262263prettyAttribute :: Attribute -> T.Text

264+prettyAttribute (Attribute _ (TypeVariableType x)) = x

263265prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr)

264266

265267resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap

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

@@ -332,12 +332,16 @@ data DatabaseContextExpr =

332332 MultipleExpr [DatabaseContextExpr]

333333 deriving (Show, Eq, Binary, Generic)

334334

335+type ObjModuleName = StringType

336+type ObjFunctionName = StringType

337+

335338-- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr.

336339data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |

337− AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript

340+ LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |

341+ AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |

342+ LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath

338343 deriving (Show, Eq, Generic, Binary)

339344

340−

341345type RestrictionPredicateExpr = RestrictionPredicateExprBase ()

342346

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

src/lib/ProjectM36/Client.hs+30−2

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

2525 typeForRelationalExpr,

2626 inclusionDependencies,

2727 ProjectM36.Client.typeConstructorMapping,

28+ ProjectM36.Client.databaseContextFunctionsAsRelation,

2829 planForDatabaseContextExpr,

2930 currentSchemaName,

3031 SchemaName,

@@ -32,6 +33,7 @@ module ProjectM36.Client

3233 setCurrentSchemaName,

3334 transactionGraphAsRelation,

3435 relationVariablesAsRelation,

36+ ProjectM36.Client.atomFunctionsAsRelation,

3537 disconnectedTransactionIsDirty,

3638 headName,

3739 remoteDBLookupName,

@@ -98,9 +100,10 @@ import ProjectM36.Base hiding (inclusionDependencies) --defined in this module a

98100import qualified ProjectM36.Base as B

99101import ProjectM36.Error

100102import ProjectM36.Atomable

101−import ProjectM36.AtomFunction

103+import ProjectM36.AtomFunction as AF

102104import ProjectM36.StaticOptimizer

103105import ProjectM36.Key

106+import ProjectM36.DatabaseContextFunction as DCF

104107import qualified ProjectM36.IsomorphicSchema as Schema

105108import Control.Monad.State

106109import Control.Monad.Trans.Reader

@@ -910,7 +913,32 @@ relationVariablesAsRelation sessionId (InProcessConnection conf) = do

910913 Left err -> pure (Left err)

911914 Right relvars -> pure $ R.relationVariablesAsRelation relvars

912915

913−relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

916+relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

917+

918+-- | Returns the names and types of the atom functions in the current 'Session'.

919+atomFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

920+atomFunctionsAsRelation sessionId (InProcessConnection conf) = do

921+ let sessions = ipSessions conf

922+ atomically $ do

923+ eSession <- sessionAndSchema sessionId sessions

924+ case eSession of

925+ Left err -> pure (Left err)

926+ Right (session, _) ->

927+ pure (AF.atomFunctionsAsRelation (atomFunctions (concreteDatabaseContext session)))

928+

929+atomFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomFunctionSummary sessionId)

930+

931+databaseContextFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

932+databaseContextFunctionsAsRelation sessionId (InProcessConnection conf) = do

933+ let sessions = ipSessions conf

934+ atomically $ do

935+ eSession <- sessionAndSchema sessionId sessions

936+ case eSession of

937+ Left err -> pure (Left err)

938+ Right (session, _) ->

939+ pure (DCF.databaseContextFunctionsAsRelation (dbcFunctions (concreteDatabaseContext session)))

940+

941+databaseContextFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveDatabaseContextFunctionSummary sessionId)

914942

915943-- | Returns the transaction id for the connection's disconnected transaction committed parent transaction.

916944headTransactionId :: SessionId -> Connection -> IO (Either RelationalError TransactionId)

src/lib/ProjectM36/DatabaseContextFunction.hs+20−1

@@ -2,8 +2,13 @@ module ProjectM36.DatabaseContextFunction where

22--implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr

33import ProjectM36.Base

44import ProjectM36.Error

5+import ProjectM36.Attribute as A

6+import ProjectM36.Relation

7+import ProjectM36.AtomType

58import qualified Data.HashSet as HS

69import qualified Data.Map as M

10+import ProjectM36.ScriptSession

11+import qualified Data.Text as T

712

813emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

914emptyDatabaseContextFunction name = DatabaseContextFunction {

@@ -53,4 +58,18 @@ databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [

5358 tCons]

5459

5560createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr

56−createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])

61+createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])

62+

63+loadDatabaseContextFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [DatabaseContextFunction])

64+loadDatabaseContextFunctions = loadFunction

65+

66+databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation

67+databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups

68+ where

69+ attrs = A.attributesFromList [Attribute "name" TextAtomType,

70+ Attribute "arguments" TextAtomType]

71+ tups = map dbcFuncToTuple (HS.toList dbcFuncs)

72+ dbcFuncToTuple func = [TextAtom (dbcFuncName func),

73+ TextAtom (dbcTextType (dbcFuncType func))]

74+ dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"])

75+

src/lib/ProjectM36/Error.hs+1

@@ -85,6 +85,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

8585 | UnhandledExceptionError String

8686 | MergeTransactionError MergeError

8787 | ScriptError ScriptCompilationError

88+ | LoadFunctionError

8889 | DatabaseContextFunctionUserError DatabaseContextFunctionError

8990 | DatabaseLoadError PersistenceError

9091

src/lib/ProjectM36/RelationalExpression.hs+14−1

@@ -561,7 +561,20 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct

561561 Right eContext -> case eContext of

562562 Left err -> pure (Left err)

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

564−

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

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

566+ case eLoadFunc of

567+ Left LoadSymbolError -> pure (Left LoadFunctionError)

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

569+ mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)

570+ in pure (Right newContext)

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

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

573+ case eLoadFunc of

574+ Left LoadSymbolError -> pure (Left LoadFunctionError)

575+ Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }

576+ mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)

577+ in pure (Right newContext)

565578

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

567580updateTupleWithAtomExprs exprMap context tupIn = do

src/lib/ProjectM36/ScriptSession.hs+40

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

1+{-# LANGUAGE MagicHash, UnboxedTuples #-}

12module ProjectM36.ScriptSession where

34import ProjectM36.Error

@@ -9,6 +10,7 @@ import System.Directory

910import Control.Monad.IO.Class

1011import System.FilePath.Glob

1112import System.FilePath

13+import System.Info (os, arch)

1214import Data.Text (Text, unpack)

1315import Data.Maybe

1416

@@ -16,6 +18,9 @@ import GHC

1618import GHC.Paths (libdir)

1719#if __GLASGOW_HASKELL__ >= 800

1820import GHC.LanguageExtensions

21+import GHCi.ObjLink

22+#else

23+import ObjLink

1924#endif

2025import DynFlags

2126import Panic

@@ -24,6 +29,10 @@ import PprTyThing

2429import Unsafe.Coerce

2530import Type

2631

32+import GHC.Exts (addrToAny#)

33+import GHC.Ptr (Ptr(..))

34+import Encoding

35+

2736data ScriptSession = ScriptSession {

2837 hscEnv :: HscEnv,

2938 atomFunctionBodyType :: Type,

@@ -174,4 +183,35 @@ typeCheckScript expectedType inp = do

174183 pure Nothing

175184 else

176185 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))

186+

187+mangleSymbol :: Maybe String -> String -> String -> String

188+mangleSymbol pkg module' valsym =

189+ prefixUnderscore ++

190+ maybe "" (\p -> zEncodeString p ++ "_") pkg ++

191+ zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure"

192+

193+type ModName = String

194+type FuncName = String

195+

196+data LoadSymbolError = LoadSymbolError

197+

198+loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)

199+loadFunction modName funcName objPath = do

200+ initObjLinker

201+ loadObj objPath

202+ _ <- resolveObjs

203+ ptr <- lookupSymbol (mangleSymbol Nothing modName funcName)

204+ case ptr of

205+ Nothing -> pure (Left LoadSymbolError)

206+ Just (Ptr addr) -> case addrToAny# addr of

207+ (# hval #) -> pure (Right hval)

177208

209+prefixUnderscore :: String

210+prefixUnderscore =

211+ case (os,arch) of

212+ ("mingw32","x86_64") -> ""

213+ ("cygwin","x86_64") -> ""

214+ ("mingw32",_) -> "_"

215+ ("darwin",_) -> "_"

216+ ("cygwin",_) -> "_"

217+ _ -> ""

src/lib/ProjectM36/Server.hs+2

@@ -41,6 +41,8 @@ serverDefinition testBool ti = defaultProcess {

4141 handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),

4242 handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),

4343 handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),

44+ handleCall (\conn (RetrieveAtomFunctionSummary sessionId) -> handleRetrieveAtomFunctionSummary ti sessionId conn),

45+ handleCall (\conn (RetrieveDatabaseContextFunctionSummary sessionId) -> handleRetrieveDatabaseContextFunctionSummary ti sessionId conn),

4446 handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),

4547 handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),

4648 handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),

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

@@ -120,6 +120,16 @@ handleRetrieveRelationVariableSummary ti sessionId conn = do

120120 ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)

121121 reply ret conn

122122

123+handleRetrieveAtomFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

124+handleRetrieveAtomFunctionSummary ti sessionId conn = do

125+ ret <- timeoutOrDie ti (atomFunctionsAsRelation sessionId conn)

126+ reply ret conn

127+

128+handleRetrieveDatabaseContextFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

129+handleRetrieveDatabaseContextFunctionSummary ti sessionId conn = do

130+ ret <- timeoutOrDie ti (databaseContextFunctionsAsRelation sessionId conn)

131+ reply ret conn

132+

123133handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName)

124134handleRetrieveCurrentSchemaName ti sessionId conn = do

125135 ret <- timeoutOrDie ti (currentSchemaName sessionId conn)

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

@@ -52,6 +52,10 @@ data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId

5252 deriving (Binary, Generic)

5353data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId

5454 deriving (Binary, Generic)

55+data RetrieveAtomFunctionSummary = RetrieveAtomFunctionSummary SessionId

56+ deriving (Binary, Generic)

57+data RetrieveDatabaseContextFunctionSummary = RetrieveDatabaseContextFunctionSummary SessionId

58+ deriving (Binary, Generic)

5559data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

5660 deriving (Binary, Generic)

5761data TestTimeout = TestTimeout SessionId