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

docs/atomfunctions.markdown+30−1

compare with master

unifiedsplit

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

6

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

8

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.

10

11## Atom Function Example

12

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

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

42```

43

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+

44## Differences when compared to other DBMSes

73## Differences when compared to other DBMSes

45

74

46Project: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.

75Project: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

6

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

8

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.

10

11## Database Context Function Types

12

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

112```

113from the same module.

114

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+

115## Future Improvements

165## Future Improvements

116

166

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

167There 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"`

4+

5+module DynamicAtomFunctions where

6+import ProjectM36.Base

7+

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

9+

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

152 ProjectM36.TypeConstructorDef,

153 ProjectM36.FileLock,

154 ProjectM36.FSType

155− GHC-Options: -Wall

155+ GHC-Options: -Wall -rdynamic

156 if os(windows)

157 Build-Depends: Win32 >= 2.3

158 Other-Modules: ProjectM36.Win32Handle

159 else

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

161 Build-Depends: unix

162− CC-Options: -fPIC

162+ CC-Options: -fPIC

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

164 Default-Language: Haskell2010

165 Default-Extensions: OverloadedStrings, CPP

166 if impl(ghc>= 8)

167 build-depends:

168− ghc-boot

168+ ghc-boot, ghci

169

170Executable tutd

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

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

225 TutorialD.Interpreter.SchemaOperator

226 main-is: TutorialD/tutd.hs

227 CC-Options: -fPIC

228− GHC-Options: -Wall

228+ GHC-Options: -Wall -rdynamic

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

230 Default-Language: Haskell2010

231 Default-Extensions: OverloadedStrings

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

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

26atomTypeSignatureP = sepBy typeConstructorP arrow

27

28dbContextIOExprP :: Parser DatabaseContextIOExpr

29−dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP

29+dbContextIOExprP = addAtomFunctionExprP <|>

30−

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

31

43

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

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

24 ShowPlan :: DatabaseContextExpr -> RODatabaseContextOperator

25 ShowTypes :: RODatabaseContextOperator

26 ShowRelationVariables :: RODatabaseContextOperator

27+ ShowAtomFunctions :: RODatabaseContextOperator

28+ ShowDatabaseContextFunctions :: RODatabaseContextOperator

27 Quit :: RODatabaseContextOperator

29 Quit :: RODatabaseContextOperator

28 deriving (Show)

30 deriving (Show)

29

31

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

48showRelationVariables :: Parser RODatabaseContextOperator

50showRelationVariables :: Parser RODatabaseContextOperator

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

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

50

52

53+showAtomFunctionsP :: Parser RODatabaseContextOperator

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

55+

56+showDatabaseContextFunctionsP :: Parser RODatabaseContextOperator

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

58+

51quitP :: Parser RODatabaseContextOperator

59quitP :: Parser RODatabaseContextOperator

52quitP = do

60quitP = do

53 reservedOp ":quit"

61 reservedOp ":quit"

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

71 <|> showConstraintsP

79 <|> showConstraintsP

72 <|> showPlanP

80 <|> showPlanP

73 <|> showTypesP

81 <|> showTypesP

82+ <|> showAtomFunctionsP

83+ <|> showDatabaseContextFunctionsP

74 <|> quitP

84 <|> quitP

75

85

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

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

125 case eRel of

135 case eRel of

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

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

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

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

128

150

129evalRODatabaseContextOp _ _ Quit = pure QuitResult

151evalRODatabaseContextOp _ _ Quit = pure QuitResult

130

152

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

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

1module ProjectM36.AtomFunction where

2import ProjectM36.Base

3import ProjectM36.Error

4+import ProjectM36.Relation

5+import ProjectM36.AtomType

4import ProjectM36.AtomFunctionError

6import ProjectM36.AtomFunctionError

7+import ProjectM36.ScriptSession

5import qualified ProjectM36.Attribute as A

8import qualified ProjectM36.Attribute as A

6import qualified Data.HashSet as HS

9import qualified Data.HashSet as HS

10+import qualified Data.Text as T

11+

7

12

8foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

13foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

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

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

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

10

16

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

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

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

64 argsType ++ [ADTypeConstructor "Either" [

70 argsType ++ [ADTypeConstructor "Either" [

65 ADTypeConstructor "AtomFunctionError" [],

71 ADTypeConstructor "AtomFunctionError" [],

66 retType]])

72 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

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

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

254 where

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

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

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

256-- 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-- 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 (TypeVariableType x) = x

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

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

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

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

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

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

261

262

262prettyAttribute :: Attribute -> T.Text

263prettyAttribute :: Attribute -> T.Text

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

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

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

264

266

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

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

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

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

332 MultipleExpr [DatabaseContextExpr]

333 deriving (Show, Eq, Binary, Generic)

334

335+type ObjModuleName = StringType

336+type ObjFunctionName = StringType

337+

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

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

336data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |

339data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |

340+ LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |

337− AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript

341+ AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |

342+ LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath

338 deriving (Show, Eq, Generic, Binary)

343 deriving (Show, Eq, Generic, Binary)

339

344

340−

341type RestrictionPredicateExpr = RestrictionPredicateExprBase ()

345type RestrictionPredicateExpr = RestrictionPredicateExprBase ()

342

346

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

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

25 typeForRelationalExpr,

26 inclusionDependencies,

27 ProjectM36.Client.typeConstructorMapping,

28+ ProjectM36.Client.databaseContextFunctionsAsRelation,

28 planForDatabaseContextExpr,

29 planForDatabaseContextExpr,

29 currentSchemaName,

30 currentSchemaName,

30 SchemaName,

31 SchemaName,

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

32 setCurrentSchemaName,

33 setCurrentSchemaName,

33 transactionGraphAsRelation,

34 transactionGraphAsRelation,

34 relationVariablesAsRelation,

35 relationVariablesAsRelation,

36+ ProjectM36.Client.atomFunctionsAsRelation,

35 disconnectedTransactionIsDirty,

37 disconnectedTransactionIsDirty,

36 headName,

38 headName,

37 remoteDBLookupName,

39 remoteDBLookupName,

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

98import qualified ProjectM36.Base as B

100import qualified ProjectM36.Base as B

99import ProjectM36.Error

101import ProjectM36.Error

100import ProjectM36.Atomable

102import ProjectM36.Atomable

101−import ProjectM36.AtomFunction

103+import ProjectM36.AtomFunction as AF

102import ProjectM36.StaticOptimizer

104import ProjectM36.StaticOptimizer

103import ProjectM36.Key

105import ProjectM36.Key

106+import ProjectM36.DatabaseContextFunction as DCF

104import qualified ProjectM36.IsomorphicSchema as Schema

107import qualified ProjectM36.IsomorphicSchema as Schema

105import Control.Monad.State

108import Control.Monad.State

106import Control.Monad.Trans.Reader

109import Control.Monad.Trans.Reader

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

910 Left err -> pure (Left err)

913 Left err -> pure (Left err)

911 Right relvars -> pure $ R.relationVariablesAsRelation relvars

914 Right relvars -> pure $ R.relationVariablesAsRelation relvars

912

915

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)

914

942

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

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

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

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

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

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

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

3import ProjectM36.Base

4import ProjectM36.Error

5+import ProjectM36.Attribute as A

6+import ProjectM36.Relation

7+import ProjectM36.AtomType

5import qualified Data.HashSet as HS

8import qualified Data.HashSet as HS

6import qualified Data.Map as M

9import qualified Data.Map as M

10+import ProjectM36.ScriptSession

11+import qualified Data.Text as T

7

12

8emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

13emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

9emptyDatabaseContextFunction name = DatabaseContextFunction {

14emptyDatabaseContextFunction name = DatabaseContextFunction {

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

53 tCons]

58 tCons]

54

59

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

60createScriptedDatabaseContextFunction :: 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)

85 | UnhandledExceptionError String

86 | MergeTransactionError MergeError

87 | ScriptError ScriptCompilationError

88+ | LoadFunctionError

88 | DatabaseContextFunctionUserError DatabaseContextFunctionError

89 | DatabaseContextFunctionUserError DatabaseContextFunctionError

89 | DatabaseLoadError PersistenceError

90 | DatabaseLoadError PersistenceError

90

91

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

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

561 Right eContext -> case eContext of

562 Left err -> pure (Left err)

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

565

578

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

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

567updateTupleWithAtomExprs exprMap context tupIn = do

580updateTupleWithAtomExprs exprMap context tupIn = do

src/lib/ProjectM36/ScriptSession.hs+40

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

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

1module ProjectM36.ScriptSession where

2module ProjectM36.ScriptSession where

2

3

3import ProjectM36.Error

4import ProjectM36.Error

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

9import Control.Monad.IO.Class

10import Control.Monad.IO.Class

10import System.FilePath.Glob

11import System.FilePath.Glob

11import System.FilePath

12import System.FilePath

13+import System.Info (os, arch)

12import Data.Text (Text, unpack)

14import Data.Text (Text, unpack)

13import Data.Maybe

15import Data.Maybe

14

16

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

16import GHC.Paths (libdir)

18import GHC.Paths (libdir)

17#if __GLASGOW_HASKELL__ >= 800

19#if __GLASGOW_HASKELL__ >= 800

18import GHC.LanguageExtensions

20import GHC.LanguageExtensions

21+import GHCi.ObjLink

22+#else

23+import ObjLink

19#endif

24#endif

20import DynFlags

25import DynFlags

21import Panic

26import Panic

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

24import Unsafe.Coerce

29import Unsafe.Coerce

25import Type

30import Type

26

31

32+import GHC.Exts (addrToAny#)

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

34+import Encoding

35+

27data ScriptSession = ScriptSession {

36data ScriptSession = ScriptSession {

28 hscEnv :: HscEnv,

37 hscEnv :: HscEnv,

29 atomFunctionBodyType :: Type,

38 atomFunctionBodyType :: Type,

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

174 pure Nothing

183 pure Nothing

175 else

184 else

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

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

177

208

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 {

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

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

43 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),

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

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

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

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

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

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

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

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

120 ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)

121 reply ret conn

122

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+

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

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

124handleRetrieveCurrentSchemaName ti sessionId conn = do

134handleRetrieveCurrentSchemaName ti sessionId conn = do

125 ret <- timeoutOrDie ti (currentSchemaName sessionId conn)

135 ret <- timeoutOrDie ti (currentSchemaName sessionId conn)

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

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

52 deriving (Binary, Generic)

53data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId

54 deriving (Binary, Generic)

55+data RetrieveAtomFunctionSummary = RetrieveAtomFunctionSummary SessionId

56+ deriving (Binary, Generic)

57+data RetrieveDatabaseContextFunctionSummary = RetrieveDatabaseContextFunctionSummary SessionId

58+ deriving (Binary, Generic)

55data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

59data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

56 deriving (Binary, Generic)

60 deriving (Binary, Generic)

57data TestTimeout = TestTimeout SessionId

61data TestTimeout = TestTimeout SessionId