2bc6417 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP compilation checkpoint

2bc6417AgentM10 years ago

ProjectM36/AtomFunction.hs+15

compare with master

unifiedsplit

@@ -15,5 +15,20 @@ atomFunctionForName funcName funcSet = if HS.null foundFunc then

15 where

16 foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet

18+-- | Create a junk named atom function for use with searching for an already existing function in the AtomFunctions HashSet.

19+emptyAtomFunction :: AtomFunctionName -> AtomFunction

20+emptyAtomFunction name = AtomFunction { atomFuncName = name,

21+ atomFuncType = [AnyAtomType, AnyAtomType],

22+ atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> x) }

25+-- | AtomFunction constructor for compiled-in functions.

26+compiledAtomFunction :: AtomFunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction

27+compiledAtomFunction name aType body = AtomFunction { atomFuncName = name,

28+ atomFuncType = aType,

29+ atomFuncBody = AtomFunctionBody Nothing body }

30+

31+--the atom function really should offer some way to return an error

32+evalAtomFunction :: AtomFunction -> [Atom] -> Atom

33+evalAtomFunction func args = case atomFuncBody func of

34+ (AtomFunctionBody _ f) -> f args

ProjectM36/AtomFunctionBody.hsnew file+92

@@ -0,0 +1,92 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

2+--tools to execute an atom function body

3+module ProjectM36.AtomFunctionBody where

4+import ProjectM36.Base

5+import ProjectM36.Error

7+import Control.Monad.IO.Class

8+import Control.Exception

9+import Data.Dynamic

10+import Data.Text

11+

12+import GHC

13+import GHC.Paths (libdir)

14+import DynFlags

15+import Outputable hiding ((<>))

16+import PprTyThing

17+import Type hiding (pprTyThing)

18+import TysWiredIn

19+

20+type ScriptSession = HscEnv

21+

22+-- | Configure a GHC environment/session which we will use for all script compilation.

23+initScriptSession :: IO ScriptSession

24+initScriptSession = runGhc (Just libdir) $ do

25+ liftIO $ putStrLn "Setting up HscEnv"

26+ dflags <- getSessionDynFlags

27+ let dflags' = dflags { hscTarget = HscInterpreted ,

28+ ghcLink = LinkInMemory,

29+ safeHaskell = Sf_Safe,

30+ safeInfer = True,

31+ safeInferred = True

32+ }

33+ `xopt_set` Opt_ExtendedDefaultRules

34+ --`xopt_unset` Opt_ImplicitPrelude

35+ `gopt_set` Opt_DistrustAllPackages

36+ `gopt_set` Opt_PackageTrust

37+ `gopt_set` Opt_ImplicitImportQualified

38+ _ <- setSessionDynFlags dflags'

39+ setContext [ IIDecl $ simpleImportDecl (mkModuleName "Prelude") ]

40+ env <- getSession

41+ return env

42+

43+addImport :: String -> Ghc ()

44+addImport moduleNam = do

45+ ctx <- getContext

46+ setContext ( (IIDecl $ simpleImportDecl (mkModuleName moduleNam)) : ctx )

47+

48+showType :: DynFlags -> Type -> String

49+showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)

50+

51+-- | Typecheck and validate the

52+typeCheckAtomFunctionScript :: AtomFunctionBodyScript -> Ghc (Maybe AtomFunctionBodyCompilationError)

53+typeCheckAtomFunctionScript inp = do

54+ dflags <- getSessionDynFlags

55+ --catch exception for SyntaxError

56+ funcType <- GHC.exprType (unpack inp)

57+

58+ let expectedType = atomFunctionBodyGhcType

59+

60+ if eqType funcType expectedType then

61+ pure Nothing

62+ else

63+ pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))

64+

65+atomFunctionBodyGhcType :: Type

66+atomFunctionBodyGhcType = Type.mkFunTy intTy intTy

67+

68+-- | After compiling the script, it must accept a list of Atoms and return an Atom, otherwise an AtomFunctionBodyCompilationError is returned

69+compileAtomFunctionScript :: AtomFunctionBodyScript -> Ghc (Either AtomFunctionBodyCompilationError AtomFunctionBodyType)

70+compileAtomFunctionScript script = do

71+ let sScript = unpack script

72+ mErr <- typeCheckAtomFunctionScript script

73+ case mErr of

74+ Just err -> pure (Left err)

75+ Nothing -> do

76+ --catch exception here

77+ --we could potentially wrap the script with Atom pattern matching so that the script doesn't have to do it, but the change to an Atom ADT should make it easier. Still, it would be nice if the script didn't have to handle a list of arguments, for example.

78+ mDyn <- fromDynamic <$> dynCompileExpr sScript

79+ case mDyn of

80+ Nothing -> pure $ Left (TypeCheckCompilationError "" "") --this really shouldn't happen

81+ Just funcBody -> pure $ Right funcBody

82+

83+catchCompileException :: MonadIO m => IO a -> m (Either AtomFunctionBodyCompilationError a)

84+catchCompileException m = liftIO $ do

85+ mres <- try m

86+ case mres of

87+ Left (err :: SomeException) -> do

88+ pure (Left (OtherScriptCompilationError (show err)))

89+ Right res -> pure (Right res)

90+

91+compiledAtomFunctionBody :: AtomFunctionBodyType -> AtomFunctionBody

92+compiledAtomFunctionBody func = AtomFunctionBody Nothing func

ProjectM36/AtomFunctions/Primitive.hs+14−12

@@ -17,42 +17,44 @@ primitiveAtomFunctions = HS.fromList [

17 --match on any relation type

18 AtomFunction { atomFuncName = "add",

19 atomFuncType = [intAtomType, intAtomType, intAtomType],

20− atomFunc = (\(i1:i2:_) -> Atom $ ((unsafeCast i1)::Int) + unsafeCast i2)},

20+ atomFuncBody = body (\(i1:i2:_) -> Atom $ ((unsafeCast i1)::Int) + unsafeCast i2)},

21 AtomFunction { atomFuncName = "id",

22 atomFuncType = [AnyAtomType, AnyAtomType],

23− atomFunc = (\(x:_) -> x)},

23+ atomFuncBody = body (\(x:_) -> x)},

24 AtomFunction { atomFuncName = "sum",

25 atomFuncType = foldAtomFuncType intAtomType intAtomType,

26− atomFunc = (\(relAtom:_) -> relationSum $ unsafeCast relAtom)},

26+ atomFuncBody = body (\(relAtom:_) -> relationSum $ unsafeCast relAtom)},

27 AtomFunction { atomFuncName = "count",

28 atomFuncType = foldAtomFuncType AnyAtomType intAtomType,

29− atomFunc = (\((relIn):_) -> relationCount (castRelation relIn))},

29+ atomFuncBody = body (\((relIn):_) -> relationCount (castRelation relIn))},

30 AtomFunction { atomFuncName = "max",

31 atomFuncType = foldAtomFuncType intAtomType intAtomType,

32− atomFunc = (\((relIn):_) -> relationMax (castRelation relIn))},

32+ atomFuncBody = body (\((relIn):_) -> relationMax (castRelation relIn))},

33 AtomFunction { atomFuncName = "min",

34 atomFuncType = foldAtomFuncType intAtomType intAtomType,

35− atomFunc = (\((relIn):_) -> relationMin (castRelation relIn))},

35+ atomFuncBody = body (\((relIn):_) -> relationMin (castRelation relIn))},

36 AtomFunction { atomFuncName = "lt",

37 atomFuncType = [intAtomType, intAtomType, boolAtomType],

38− atomFunc = intAtomFuncLessThan False},

38+ atomFuncBody = body $ intAtomFuncLessThan False},

39 AtomFunction { atomFuncName = "lte",

40 atomFuncType = [intAtomType, intAtomType, boolAtomType],

41− atomFunc = intAtomFuncLessThan True},

41+ atomFuncBody = body $ intAtomFuncLessThan True},

42 AtomFunction { atomFuncName = "gte",

43 atomFuncType = [intAtomType, intAtomType, boolAtomType],

44− atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan False},

44+ atomFuncBody = body $ boolAtomNot . (:[]) . intAtomFuncLessThan False},

45 AtomFunction { atomFuncName = "gt",

46 atomFuncType = [intAtomType, intAtomType, boolAtomType],

47− atomFunc = boolAtomNot . (:[]) . intAtomFuncLessThan True},

47+ atomFuncBody = body $ boolAtomNot . (:[]) . intAtomFuncLessThan True},

48 AtomFunction { atomFuncName = "not",

49 atomFuncType = [boolAtomType, boolAtomType],

50− atomFunc = boolAtomNot},

50+ atomFuncBody = body boolAtomNot},

51 AtomFunction { atomFuncName = "makeByteString",

52 atomFuncType = [textAtomType, byteStringAtomType],

53 --I need a proper error-handling scheme for AtomFunctions!

54− atomFunc = \(textIn:_) -> Atom $ (B64.decodeLenient . TE.encodeUtf8) ((unsafeCast textIn)::T.Text) }

54+ atomFuncBody = body $ \(textIn:_) -> Atom $ (B64.decodeLenient . TE.encodeUtf8) ((unsafeCast textIn)::T.Text) }

55 ]

56+ where

57+ body = AtomFunctionBody Nothing

57unsafeCast :: (Atomable a) => Atom -> a

59unsafeCast :: (Atomable a) => Atom -> a

58unsafeCast (ConstructedAtom _ _ _) = error "unsafeCast attempt on ConstructedAtom"

60unsafeCast (ConstructedAtom _ _ _) = error "unsafeCast attempt on ConstructedAtom"

ProjectM36/AtomType.hs+1

@@ -264,3 +264,4 @@ prettyAtomType AnyAtomType = "?AnyAtomType?"

264

265prettyAttribute :: Attribute -> T.Text

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

267+

ProjectM36/Base.hs+32−6

@@ -25,6 +25,7 @@ import Data.ByteString (ByteString)

25import ProjectM36.ConcreteTypeRep

26import qualified Data.Text.Encoding as TE

27import qualified Data.ByteString.Base64 as BS64

28+import Data.Maybe (isJust)

29type StringType = Text

30type StringType = Text

@@ -347,13 +348,15 @@ data DatabaseContextExpr =

347 AddTypeConstructor TypeConstructorDef [DataConstructorDef] |

348 AddTypeConstructor TypeConstructorDef [DataConstructorDef] |

348 RemoveTypeConstructor TypeConstructorName |

349 RemoveTypeConstructor TypeConstructorName |

349

350

350− -- to implement this, I likely need to implement a DSL for constructing arbitrary functions to operate on atoms at runtime

351+ --adding an AtomFunction is not a pure operation (required loading GHC modules)

351− --AddAtomFunction AtomFunction

352− --RemoveAtomFunction AtomFunctionName

352+ RemoveAtomFunction AtomFunctionName |

353

354 MultipleExpr [DatabaseContextExpr]

355 deriving (Show, Eq, Binary, Generic)

356

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

358+data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript

359+ deriving (Show, Eq, Generic, Binary)

357

360

358type DatabaseState a = State DatabaseContext a

361type DatabaseState a = State DatabaseContext a

359

362

@@ -438,22 +441,45 @@ type AtomFunctions = HS.HashSet AtomFunction

438

441

439type AtomFunctionName = StringType

442type AtomFunctionName = StringType

440

443

444+type AtomFunctionBodyScript = StringType

445+

446+type AtomFunctionBodyType = [Atom] -> Atom

447+

448+data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType

449+

450+instance Show AtomFunctionBody where

451+ show (AtomFunctionBody mScript _) = case mScript of

452+ Just script -> show (unpack script)

453+ Nothing -> "<compiled>"

454+

441-- | An AtomFunction has a name, a type, and a function body to execute when called.

455-- | An AtomFunction has a name, a type, and a function body to execute when called.

442data AtomFunction = AtomFunction {

456data AtomFunction = AtomFunction {

443 atomFuncName :: AtomFunctionName,

457 atomFuncName :: AtomFunctionName,

444 atomFuncType :: [AtomType],

458 atomFuncType :: [AtomType],

445− atomFunc :: [Atom] -> Atom

459+ atomFuncBody :: AtomFunctionBody

446 }

460 }

447

461

448instance Hashable AtomFunction where

462instance Hashable AtomFunction where

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

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

450

464

451instance Eq AtomFunction where

465instance Eq AtomFunction where

466+ f1 == f2 = let (AtomFunctionBody mScript1 _) = atomFuncBody f1

467+ (AtomFunctionBody mScript2 _) = atomFuncBody f2 in

452− f1 == f2 = (atomFuncName f1) == (atomFuncName f2)

468+ if atomFuncName f1 == atomFuncName f2 then

469+ if isJust mScript1 then

470+ if mScript1 == mScript2 then

471+ True

472+ else

473+ False

474+ else

475+ True

476+ else

477+ False

453

478

454instance Show AtomFunction where

479instance Show AtomFunction where

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

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

456 where

481 where

482+ body = show (atomFuncBody aFunc)

457 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))

483 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))

458

484

459-- | The 'AttributeNames' structure represents a set of attribute names or the same set of names but inverted in the context of a relational expression. For example, if a relational expression has attributes named "a", "b", and "c", the 'InvertedAttributeNames' of ("a","c") is ("b").

485-- | The 'AttributeNames' structure represents a set of attribute names or the same set of names but inverted in the context of a relational expression. For example, if a relational expression has attributes named "a", "b", and "c", the 'InvertedAttributeNames' of ("a","c") is ("b").

ProjectM36/Client.hs+46−24

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

10 close,

11 executeRelationalExpr,

12 executeDatabaseContextExpr,

13+ executeDatabaseContextIOExpr,

13 executeGraphExpr,

14 executeGraphExpr,

14 commit,

15 commit,

15 rollback,

16 rollback,

@@ -64,6 +65,7 @@ import ProjectM36.Persist (DiskSync(..))

64import ProjectM36.Notifications

65import ProjectM36.Notifications

65import ProjectM36.Server.RemoteCallTypes

66import ProjectM36.Server.RemoteCallTypes

66import ProjectM36.Relation (typesAsRelation)

67import ProjectM36.Relation (typesAsRelation)

68+import ProjectM36.AtomFunctionBody (initScriptSession, ScriptSession)

67import qualified ProjectM36.Relation as R

69import qualified ProjectM36.Relation as R

68import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPointAddress)

70import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPointAddress)

69import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess)

71import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess)

@@ -137,7 +139,7 @@ defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (c

137-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

139-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

138type ClientNodes = STMSet.Set ProcessId

140type ClientNodes = STMSet.Set ProcessId

139

141

140−data Connection = InProcessConnection PersistenceStrategy ClientNodes Sessions (TVar TransactionGraph) |

142+data Connection = InProcessConnection PersistenceStrategy ClientNodes Sessions (TVar TransactionGraph) ScriptSession |

141 RemoteProcessConnection LocalNode ProcessId

143 RemoteProcessConnection LocalNode ProcessId

142

144

143-- | There are several reasons why a connection can fail.

145-- | There are several reasons why a connection can fail.

@@ -193,7 +195,8 @@ connectProjectM36 (InProcessConnectionInfo strat notificationCallback) = do

193 clientNodes <- STMSet.newIO

195 clientNodes <- STMSet.newIO

194 sessions <- STMMap.newIO

196 sessions <- STMMap.newIO

195 notificationPid <- startNotificationListener notificationCallback

197 notificationPid <- startNotificationListener notificationCallback

198+ interpreterSession <- initScriptSession

196− let conn = InProcessConnection strat clientNodes sessions graphTvar

199+ let conn = InProcessConnection strat clientNodes sessions graphTvar interpreterSession

197 addClientNode conn notificationPid

200 addClientNode conn notificationPid

198 pure (Right conn)

201 pure (Right conn)

199 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback

202 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback

@@ -239,21 +242,22 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback = d

239 tvarGraph <- newTVarIO graph'

242 tvarGraph <- newTVarIO graph'

240 sessions <- STMMap.newIO

243 sessions <- STMMap.newIO

241 clientNodes <- STMSet.newIO

244 clientNodes <- STMSet.newIO

245+ scriptSession <- initScriptSession

242− let conn = InProcessConnection strat clientNodes sessions tvarGraph

246+ let conn = InProcessConnection strat clientNodes sessions tvarGraph scriptSession

243 notificationPid <- startNotificationListener notificationCallback

247 notificationPid <- startNotificationListener notificationCallback

244 addClientNode conn notificationPid

248 addClientNode conn notificationPid

245 pure (Right conn)

249 pure (Right conn)

246

250

247-- | Create a new session at the transaction id and return the session's Id.

251-- | Create a new session at the transaction id and return the session's Id.

248createSessionAtCommit :: TransactionId -> Connection -> IO (Either RelationalError SessionId)

252createSessionAtCommit :: TransactionId -> Connection -> IO (Either RelationalError SessionId)

249−createSessionAtCommit commitId conn@(InProcessConnection _ _ _ _) = do

253+createSessionAtCommit commitId conn@(InProcessConnection _ _ _ _ _) = do

250 newSessionId <- nextRandom

254 newSessionId <- nextRandom

251 atomically $ do

255 atomically $ do

252 createSessionAtCommit_ commitId newSessionId conn

256 createSessionAtCommit_ commitId newSessionId conn

253createSessionAtCommit uuid conn@(RemoteProcessConnection _ _) = remoteCall conn (CreateSessionAtCommit uuid)

257createSessionAtCommit uuid conn@(RemoteProcessConnection _ _) = remoteCall conn (CreateSessionAtCommit uuid)

254

258

255createSessionAtCommit_ :: TransactionId -> SessionId -> Connection -> STM (Either RelationalError SessionId)

259createSessionAtCommit_ :: TransactionId -> SessionId -> Connection -> STM (Either RelationalError SessionId)

256−createSessionAtCommit_ commitId newSessionId (InProcessConnection _ _ sessions graphTvar) = do

260+createSessionAtCommit_ commitId newSessionId (InProcessConnection _ _ sessions graphTvar _) = do

257 graph <- readTVar graphTvar

261 graph <- readTVar graphTvar

258 case transactionForId commitId graph of

262 case transactionForId commitId graph of

259 Left err -> pure (Left err)

263 Left err -> pure (Left err)

@@ -269,7 +273,7 @@ createSessionAtCommit_ _ _ (RemoteProcessConnection _ _) = error "createSessionA

269

273

270-- | Call 'createSessionAtHead' with a transaction graph's head's name to create a new session pinned to that head. This function returns a 'SessionId' which can be used in other function calls to reference the point in the transaction graph.

274-- | Call 'createSessionAtHead' with a transaction graph's head's name to create a new session pinned to that head. This function returns a 'SessionId' which can be used in other function calls to reference the point in the transaction graph.

271createSessionAtHead :: HeadName -> Connection -> IO (Either RelationalError SessionId)

275createSessionAtHead :: HeadName -> Connection -> IO (Either RelationalError SessionId)

272−createSessionAtHead headn conn@(InProcessConnection _ _ _ graphTvar) = do

276+createSessionAtHead headn conn@(InProcessConnection _ _ _ graphTvar _) = do

273 newSessionId <- nextRandom

277 newSessionId <- nextRandom

274 atomically $ do

278 atomically $ do

275 graph <- readTVar graphTvar

279 graph <- readTVar graphTvar

@@ -281,16 +285,16 @@ createSessionAtHead headn conn@(RemoteProcessConnection _ _) = remoteCall conn (

281-- | Used internally for server connections to keep track of remote nodes for the purpose of sending notifications later.

285-- | Used internally for server connections to keep track of remote nodes for the purpose of sending notifications later.

282addClientNode :: Connection -> ProcessId -> IO ()

286addClientNode :: Connection -> ProcessId -> IO ()

283addClientNode (RemoteProcessConnection _ _) _ = error "addClientNode called on remote connection"

287addClientNode (RemoteProcessConnection _ _) _ = error "addClientNode called on remote connection"

284−addClientNode (InProcessConnection _ clientNodes _ _) newProcessId = atomically (STMSet.insert newProcessId clientNodes)

288+addClientNode (InProcessConnection _ clientNodes _ _ _) newProcessId = atomically (STMSet.insert newProcessId clientNodes)

285

289

286-- | Discards a session, eliminating any uncommitted changes present in the session.

290-- | Discards a session, eliminating any uncommitted changes present in the session.

287closeSession :: SessionId -> Connection -> IO ()

291closeSession :: SessionId -> Connection -> IO ()

288−closeSession sessionId (InProcessConnection _ _ sessions _) = do

292+closeSession sessionId (InProcessConnection _ _ sessions _ _) = do

289 atomically $ STMMap.delete sessionId sessions

293 atomically $ STMMap.delete sessionId sessions

290closeSession sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (CloseSession sessionId)

294closeSession sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (CloseSession sessionId)

291-- | 'close' cleans up the database access connection. Note that sessions persist even after the connection is closed.

295-- | 'close' cleans up the database access connection. Note that sessions persist even after the connection is closed.

292close :: Connection -> IO ()

296close :: Connection -> IO ()

293−close (InProcessConnection _ _ sessions _) = atomically $ do

297+close (InProcessConnection _ _ sessions _ _) = atomically $ do

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

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

295 pure ()

299 pure ()

296

300

@@ -307,7 +311,7 @@ runProcessResult localNode proc = do

307 takeMVar ret

311 takeMVar ret

308

312

309remoteCall :: (Serializable a, Serializable b) => Connection -> a -> IO b

313remoteCall :: (Serializable a, Serializable b) => Connection -> a -> IO b

310−remoteCall (InProcessConnection _ _ _ _) _ = error "remoteCall called on local connection"

314+remoteCall (InProcessConnection _ _ _ _ _) _ = error "remoteCall called on local connection"

311remoteCall (RemoteProcessConnection localNode serverProcessId) arg = runProcessResult localNode $ do

315remoteCall (RemoteProcessConnection localNode serverProcessId) arg = runProcessResult localNode $ do

312 ret <- safeCall serverProcessId arg

316 ret <- safeCall serverProcessId arg

313 case ret of

317 case ret of

@@ -321,7 +325,7 @@ sessionForSessionId sessionId sessions = do

321

325

322-- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database.

326-- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database.

323executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

327executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

324−executeRelationalExpr sessionId (InProcessConnection _ _ sessions _) expr = atomically $ do

328+executeRelationalExpr sessionId (InProcessConnection _ _ sessions _ _) expr = atomically $ do

325 eSession <- sessionForSessionId sessionId sessions

329 eSession <- sessionForSessionId sessionId sessions

326 case eSession of

330 case eSession of

327 Left err -> pure $ Left err

331 Left err -> pure $ Left err

@@ -330,7 +334,7 @@ executeRelationalExpr sessionId conn@(RemoteProcessConnection _ _) relExpr = rem

330

334

331-- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.

335-- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.

332executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Maybe RelationalError)

336executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Maybe RelationalError)

333−executeDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _) expr = atomically $ do

337+executeDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _ _) expr = atomically $ do

334 eSession <- sessionForSessionId sessionId sessions

338 eSession <- sessionForSessionId sessionId sessions

335 case eSession of

339 case eSession of

336 Left err -> pure $ Just err

340 Left err -> pure $ Just err

@@ -342,6 +346,24 @@ executeDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _) expr =

342 STMMap.insert newSession sessionId sessions

346 STMMap.insert newSession sessionId sessions

343 return Nothing

347 return Nothing

344executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

348executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

349+

350+-- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr` modify the DatabaseContext but cannot be purely implemented.

351+--this is almost completely identical to executeDatabaseContextExpr above

352+executeDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> IO (Maybe RelationalError)

353+executeDatabaseContextIOExpr sessionId (InProcessConnection _ _ sessions _ scriptSession) expr = do

354+ eSession <- atomically $ sessionForSessionId sessionId sessions --potentially race condition due to interleaved IO?

355+ case eSession of

356+ Left err -> pure $ Just err

357+ Right session -> do

358+ res <- RE.evalDatabaseContextIOExpr scriptSession (sessionContext session) expr

359+ case res of

360+ Left err -> pure (Just err)

361+ Right context' -> do

362+ let newDiscon = DisconnectedTransaction (sessionParentId session) context'

363+ newSession = Session newDiscon

364+ atomically $ STMMap.insert newSession sessionId sessions

365+ pure Nothing

366+executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)

345

367

346executeGraphExprSTM_ :: TransactionId -> SessionId -> Sessions -> TransactionGraphOperator -> TVar TransactionGraph -> STM (Either RelationalError TransactionGraph)

368executeGraphExprSTM_ :: TransactionId -> SessionId -> Sessions -> TransactionGraphOperator -> TVar TransactionGraph -> STM (Either RelationalError TransactionGraph)

347executeGraphExprSTM_ freshId sessionId sessions graphExpr graphTvar = do

369executeGraphExprSTM_ freshId sessionId sessions graphExpr graphTvar = do

@@ -369,7 +391,7 @@ executeCommitExprSTM_ oldContext newContext nodes = do

369

391

370-- | Execute a transaction graph expression in the context of the session and connection. Transaction graph operators modify the transaction graph state.

392-- | Execute a transaction graph expression in the context of the session and connection. Transaction graph operators modify the transaction graph state.

371executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (Maybe RelationalError)

393executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (Maybe RelationalError)

372−executeGraphExpr sessionId (InProcessConnection strat clientNodes sessions graphTvar) graphExpr = do

394+executeGraphExpr sessionId (InProcessConnection strat clientNodes sessions graphTvar _) graphExpr = do

373 freshId <- nextRandom

395 freshId <- nextRandom

374 manip <- atomically $ do

396 manip <- atomically $ do

375 eSession <- sessionForSessionId sessionId sessions

397 eSession <- sessionForSessionId sessionId sessions

@@ -411,7 +433,7 @@ commitSTM_ freshUUID sessionId sessions graph = do

411

433

412-- | After modifying a session, 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated.

434-- | After modifying a session, 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated.

413commit :: SessionId -> Connection -> IO (Maybe RelationalError)

435commit :: SessionId -> Connection -> IO (Maybe RelationalError)

414−commit sessionId conn@(InProcessConnection _ _ _ _) = executeGraphExpr sessionId conn Commit

436+commit sessionId conn@(InProcessConnection _ _ _ _ _) = executeGraphExpr sessionId conn Commit

415commit sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteGraphExpr sessionId Commit)

437commit sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteGraphExpr sessionId Commit)

416

438

417sendNotifications :: [ProcessId] -> EvaluatedNotifications -> IO ()

439sendNotifications :: [ProcessId] -> EvaluatedNotifications -> IO ()

@@ -425,7 +447,7 @@ sendNotifications pids nots = mapM_ sendNots pids

425

447

426-- | Discard any changes made in the current session. This resets the disconnected transaction to reference the original database context of the parent transaction and is a very cheap operation.

448-- | Discard any changes made in the current session. This resets the disconnected transaction to reference the original database context of the parent transaction and is a very cheap operation.

427rollback :: SessionId -> Connection -> IO (Maybe RelationalError)

449rollback :: SessionId -> Connection -> IO (Maybe RelationalError)

428−rollback sessionId conn@(InProcessConnection _ _ _ _) = executeGraphExpr sessionId conn Rollback

450+rollback sessionId conn@(InProcessConnection _ _ _ _ _) = executeGraphExpr sessionId conn Rollback

429rollback sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteGraphExpr sessionId Rollback)

451rollback sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteGraphExpr sessionId Rollback)

430

452

431processPersistence :: PersistenceStrategy -> TransactionGraph -> IO ()

453processPersistence :: PersistenceStrategy -> TransactionGraph -> IO ()

@@ -435,11 +457,11 @@ processPersistence (CrashSafePersistence dbdir) graph = transactionGraphPersist

435

457

436-- | Return a relation whose type would match that of the relational expression if it were executed. This is useful for checking types and validating a relational expression's types.

458-- | Return a relation whose type would match that of the relational expression if it were executed. This is useful for checking types and validating a relational expression's types.

437typeForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

459typeForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)

438−typeForRelationalExpr sessionId conn@(InProcessConnection _ _ _ _) relExpr = atomically $ typeForRelationalExprSTM sessionId conn relExpr

460+typeForRelationalExpr sessionId conn@(InProcessConnection _ _ _ _ _) relExpr = atomically $ typeForRelationalExprSTM sessionId conn relExpr

439typeForRelationalExpr sessionId conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr sessionId relExpr)

461typeForRelationalExpr sessionId conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr sessionId relExpr)

440

462

441typeForRelationalExprSTM :: SessionId -> Connection -> RelationalExpr -> STM (Either RelationalError Relation)

463typeForRelationalExprSTM :: SessionId -> Connection -> RelationalExpr -> STM (Either RelationalError Relation)

442−typeForRelationalExprSTM sessionId (InProcessConnection _ _ sessions _) relExpr = do

464+typeForRelationalExprSTM sessionId (InProcessConnection _ _ sessions _ _) relExpr = do

443 eSession <- sessionForSessionId sessionId sessions

465 eSession <- sessionForSessionId sessionId sessions

444 case eSession of

466 case eSession of

445 Left err -> pure $ Left err

467 Left err -> pure $ Left err

@@ -449,7 +471,7 @@ typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-l

449

471

450-- | Return a 'Map' of the database's constraints at the context of the session and connection.

472-- | Return a 'Map' of the database's constraints at the context of the session and connection.

451inclusionDependencies :: SessionId -> Connection -> IO (Either RelationalError (M.Map IncDepName InclusionDependency))

473inclusionDependencies :: SessionId -> Connection -> IO (Either RelationalError (M.Map IncDepName InclusionDependency))

452−inclusionDependencies sessionId (InProcessConnection _ _ sessions _) = do

474+inclusionDependencies sessionId (InProcessConnection _ _ sessions _ _) = do

453 atomically $ do

475 atomically $ do

454 eSession <- sessionForSessionId sessionId sessions

476 eSession <- sessionForSessionId sessionId sessions

455 case eSession of

477 case eSession of

@@ -460,7 +482,7 @@ inclusionDependencies sessionId conn@(RemoteProcessConnection _ _) = remoteCall

460

482

461-- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated.

483-- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated.

462planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError DatabaseContextExpr)

484planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError DatabaseContextExpr)

463−planForDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _) dbExpr = do

485+planForDatabaseContextExpr sessionId (InProcessConnection _ _ sessions _ _) dbExpr = do

464 atomically $ do

486 atomically $ do

465 eSession <- sessionForSessionId sessionId sessions

487 eSession <- sessionForSessionId sessionId sessions

466 case eSession of

488 case eSession of

@@ -474,7 +496,7 @@ planForDatabaseContextExpr sessionId conn@(RemoteProcessConnection _ _) dbExpr =

474-- * id- id attribute of the transaction

496-- * id- id attribute of the transaction

475-- * parents- a relation-valued attribute which contains a relation of transaction ids which are parent transaction to the transaction

497-- * parents- a relation-valued attribute which contains a relation of transaction ids which are parent transaction to the transaction

476transactionGraphAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

498transactionGraphAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

477−transactionGraphAsRelation sessionId (InProcessConnection _ _ sessions tvar) = do

499+transactionGraphAsRelation sessionId (InProcessConnection _ _ sessions tvar _) = do

478 atomically $ do

500 atomically $ do

479 eSession <- sessionForSessionId sessionId sessions

501 eSession <- sessionForSessionId sessionId sessions

480 case eSession of

502 case eSession of

@@ -486,7 +508,7 @@ transactionGraphAsRelation sessionId (InProcessConnection _ _ sessions tvar) = d

486transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveTransactionGraph sessionId)

508transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveTransactionGraph sessionId)

487

509

488relationVariablesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

510relationVariablesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

489−relationVariablesAsRelation sessionId (InProcessConnection _ _ sessions _) = do

511+relationVariablesAsRelation sessionId (InProcessConnection _ _ sessions _ _) = do

490 atomically $ do

512 atomically $ do

491 eSession <- sessionForSessionId sessionId sessions

513 eSession <- sessionForSessionId sessionId sessions

492 case eSession of

514 case eSession of

@@ -497,7 +519,7 @@ relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _ _) = remot

497

519

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

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

499headTransactionId :: SessionId -> Connection -> IO (Maybe TransactionId)

521headTransactionId :: SessionId -> Connection -> IO (Maybe TransactionId)

500−headTransactionId sessionId (InProcessConnection _ _ sessions _) = do

522+headTransactionId sessionId (InProcessConnection _ _ sessions _ _) = do

501 atomically $ do

523 atomically $ do

502 eSession <- sessionForSessionId sessionId sessions

524 eSession <- sessionForSessionId sessionId sessions

503 case eSession of

525 case eSession of

@@ -517,12 +539,12 @@ headNameSTM_ sessionId sessions graphTvar = do

517

539

518-- | Returns Just the name of the head of the current disconnected transaction or Nothing.

540-- | Returns Just the name of the head of the current disconnected transaction or Nothing.

519headName :: SessionId -> Connection -> IO (Maybe HeadName)

541headName :: SessionId -> Connection -> IO (Maybe HeadName)

520−headName sessionId (InProcessConnection _ _ sessions graphTvar) = do

542+headName sessionId (InProcessConnection _ _ sessions graphTvar _) = do

521 atomically (headNameSTM_ sessionId sessions graphTvar)

543 atomically (headNameSTM_ sessionId sessions graphTvar)

522headName sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteHeadName sessionId)

544headName sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteHeadName sessionId)

523

545

524atomTypesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

546atomTypesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

525−atomTypesAsRelation sessionId (InProcessConnection _ _ sessions _) = do

547+atomTypesAsRelation sessionId (InProcessConnection _ _ sessions _ _) = do

526 atomically $ do

548 atomically $ do

527 eSession <- sessionForSessionId sessionId sessions

549 eSession <- sessionForSessionId sessionId sessions

528 case eSession of

550 case eSession of

ProjectM36/DataTypes/Day.hs+3−3

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

1module ProjectM36.DataTypes.Day where

2import ProjectM36.Base

3+import ProjectM36.AtomFunctionBody

3import ProjectM36.DataTypes.Primitive

4import ProjectM36.DataTypes.Primitive

4import ProjectM36.AtomFunctions.Primitive

5import ProjectM36.AtomFunctions.Primitive

5import qualified Data.HashSet as HS

6import qualified Data.HashSet as HS

6import Data.Time.Calendar

7import Data.Time.Calendar

7import qualified Data.Map as M

8import qualified Data.Map as M

9−

10dayAtom :: Day -> Atom

11dayAtom d = Atom d

@@ -17,11 +17,11 @@ dayAtomFunctions :: AtomFunctions

17dayAtomFunctions = HS.fromList [

18 AtomFunction { atomFuncName = "fromGregorian",

19 atomFuncType = [intAtomType, intAtomType, intAtomType, dayAtomType],

20− atomFunc = \(year:month:day:_) -> ConstructedAtom "Day" dayAtomType [Atom (fromGregorian (fromIntegral (unsafeCast year::Int)) (unsafeCast month) (unsafeCast day))]

20+ atomFuncBody = compiledAtomFunctionBody $ \(year:month:day:_) -> ConstructedAtom "Day" dayAtomType [Atom (fromGregorian (fromIntegral (unsafeCast year::Int)) (unsafeCast month) (unsafeCast day))]

21 },

22 AtomFunction { atomFuncName = "dayEarlierThan",

23 atomFuncType = [dayAtomType, dayAtomType, boolAtomType],

24− atomFunc = \((ConstructedAtom _ _ (dayA:_)):(ConstructedAtom _ _ (dayB:_)):_) -> Atom (unsafeCast dayA < (unsafeCast dayB :: Day))

24+ atomFuncBody = compiledAtomFunctionBody $ \((ConstructedAtom _ _ (dayA:_)):(ConstructedAtom _ _ (dayB:_)):_) -> Atom (unsafeCast dayA < (unsafeCast dayB :: Day))

25 }

26 ]

ProjectM36/DataTypes/Either.hs+2−4

@@ -1,6 +1,7 @@

1module ProjectM36.DataTypes.Either where

2import ProjectM36.Base

3import ProjectM36.DataTypes.Primitive

4+import ProjectM36.AtomFunction

4import qualified Data.HashSet as HS

5import qualified Data.HashSet as HS

5import qualified Data.Map as M

6import qualified Data.Map as M

@@ -14,8 +15,5 @@ eitherTypeConstructorMapping = [(ADTypeConstructorDef "Either" ["a", "b"],

15eitherAtomFunctions :: AtomFunctions

16eitherAtomFunctions :: AtomFunctions

16eitherAtomFunctions = HS.fromList [

17eitherAtomFunctions = HS.fromList [

17− AtomFunction { atomFuncName = "isLeft",

18− atomFuncType = [eitherAtomType AnyAtomType AnyAtomType, boolAtomType],

18+ compiledAtomFunction "isLeft" [eitherAtomType AnyAtomType AnyAtomType, boolAtomType] $ \((ConstructedAtom dConsName _ _):_) -> Atom (dConsName == "Left")

19− atomFunc = \((ConstructedAtom dConsName _ _):_) -> Atom (dConsName == "Left")

20− }

21 ]

19 ]

ProjectM36/DataTypes/Maybe.hs+1−1

@@ -18,6 +18,6 @@ maybeAtomFunctions = HS.fromList [

18 AtomFunction {

19 atomFuncName ="isJust",

20 atomFuncType = [maybeAtomType AnyAtomType, boolAtomType],

21− atomFunc = \((ConstructedAtom dConsName _ _):_) -> Atom (dConsName == "Nothing")

21+ atomFuncBody = AtomFunctionBody Nothing $ \((ConstructedAtom dConsName _ _):_) -> Atom (dConsName == "Nothing")

22 }

23 ]

ProjectM36/Error.hs+10−1

@@ -53,6 +53,8 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

53 | AtomTypeNameInUseError AtomTypeName

54 | IncompletelyDefinedAtomTypeWithConstructorError

55 | AtomTypeNameNotInUseError AtomTypeName

56+ | AtomFunctionNameInUseError AtomFunctionName

57+ | AtomFunctionNameNotInUseError AtomFunctionName

56 | NoSuchDataConstructorError DataConstructorName

58 | NoSuchDataConstructorError DataConstructorName

57 | NoSuchTypeConstructorError TypeConstructorName

59 | NoSuchTypeConstructorError TypeConstructorName

58 | InvalidAtomTypeName AtomTypeName

60 | InvalidAtomTypeName AtomTypeName

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

67 | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra

69 | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra

68 | ExportError T.Text

70 | ExportError T.Text

69 | MergeTransactionError MergeError

71 | MergeTransactionError MergeError

72+ | AtomFunctionBodyScriptError AtomFunctionBodyCompilationError

70 | MultipleErrors [RelationalError]

73 | MultipleErrors [RelationalError]

71 deriving (Show,Eq,Generic,Binary,Typeable)

74 deriving (Show,Eq,Generic,Binary,Typeable)

@@ -94,4 +97,10 @@ data MergeError = SelectedHeadMismatchMergeError |

94 StrategyViolatesTypeConstructorMergeError

97 StrategyViolatesTypeConstructorMergeError

95 deriving (Show, Eq, Generic, Binary, Typeable)

98 deriving (Show, Eq, Generic, Binary, Typeable)

97−instance NFData MergeError where rnf = genericRnf

100+instance NFData MergeError where rnf = genericRnf

101+

102+data AtomFunctionBodyCompilationError = TypeCheckCompilationError String String | --expected, got

103+ SyntaxErrorCompilationError String |

104+ OtherScriptCompilationError String

105+ deriving (Show,Eq, Generic, Binary, Typeable, NFData)

106+

ProjectM36/RelationalExpression.hs+48−3

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

1+{-# LANGUAGE ScopedTypeVariables #-}

1module ProjectM36.RelationalExpression where

2module ProjectM36.RelationalExpression where

2import ProjectM36.Relation

3import ProjectM36.Relation

3import ProjectM36.Tuple

4import ProjectM36.Tuple

@@ -5,19 +6,24 @@ import ProjectM36.TupleSet

5import ProjectM36.Base

6import ProjectM36.Base

6import ProjectM36.Error

7import ProjectM36.Error

7import ProjectM36.AtomType

8import ProjectM36.AtomType

9+import ProjectM36.AtomFunctionBody

8import ProjectM36.DataTypes.Primitive

10import ProjectM36.DataTypes.Primitive

9import ProjectM36.AtomFunction

11import ProjectM36.AtomFunction

10import qualified ProjectM36.Attribute as A

12import qualified ProjectM36.Attribute as A

11import qualified Data.Map as M

13import qualified Data.Map as M

12import qualified Data.HashSet as HS

14import qualified Data.HashSet as HS

13import Control.Monad.State hiding (join)

15import Control.Monad.State hiding (join)

16+import Control.Exception

14import Data.Maybe

17import Data.Maybe

15import Data.Either

18import Data.Either

16import Data.Char (isUpper)

19import Data.Char (isUpper)

17import qualified Data.Text as T

20import qualified Data.Text as T

18import qualified Data.Vector as V

21import qualified Data.Vector as V

19import qualified ProjectM36.TypeConstructorDef as TCD

22import qualified ProjectM36.TypeConstructorDef as TCD

23+

24+import GHC

25+import GHC.Paths

20−import Debug.Trace

26+--import Debug.Trace

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

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

23evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)

29evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)

@@ -321,6 +327,45 @@ evalContextExpr (MultipleExpr exprs) = do

321 case catMaybes evald of

327 case catMaybes evald of

322 [] -> return $ Nothing

328 [] -> return $ Nothing

323 err:_ -> return $ Just err

329 err:_ -> return $ Just err

330+

331+evalContextExpr (RemoveAtomFunction funcName) = do

332+ currentContext <- get

333+ let atomFuncs = atomFunctions currentContext

334+ dudFunc = emptyAtomFunction funcName -- just for lookup in the hashset

335+ if HS.member dudFunc atomFuncs then do

336+ let updatedFuncs = HS.delete dudFunc atomFuncs

337+ put (currentContext {atomFunctions = updatedFuncs })

338+ pure Nothing

339+ else

340+ pure (Just (AtomFunctionNameNotInUseError funcName))

341+

342+evalDatabaseContextIOExpr :: HscEnv -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)

343+evalDatabaseContextIOExpr hscEnv currentContext (AddAtomFunction funcName funcType script) = do

344+ res <- try $ runGhc (Just libdir) $ do

345+ setSession hscEnv

346+ let atomFuncs = atomFunctions currentContext

347+ --compile the function

348+ eCompiledFunc <- compileAtomFunctionScript script

349+ pure $ case eCompiledFunc of

350+ Left err -> Left (AtomFunctionBodyScriptError err)

351+ Right compiledFunc -> do

352+ funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext)) funcType

353+ let updatedFuncs = HS.insert newAtomFunc atomFuncs

354+ newContext = currentContext { atomFunctions = updatedFuncs }

355+ newAtomFunc = AtomFunction { atomFuncName = funcName,

356+ atomFuncType = funcAtomType,

357+ atomFuncBody = AtomFunctionBody (Just script) compiledFunc }

358+

359+ -- check if the name is already in use

360+ if HS.member newAtomFunc atomFuncs then

361+ Left (AtomFunctionNameInUseError funcName)

362+ else do

363+ Right newContext

364+ case res of

365+ Left (exc :: SomeException) -> pure $ Left (AtomFunctionBodyScriptError (OtherScriptCompilationError (show exc)))

366+ Right eContext -> case eContext of

367+ Left err -> pure (Left err)

368+ Right context' -> pure (Right context')

324

369

325updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

370updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

326updateTupleWithAtomExprs exprMap context tupIn = do

371updateTupleWithAtomExprs exprMap context tupIn = do

@@ -460,7 +505,7 @@ evalAtomExpr tupIn context (FunctionAtomExpr funcName arguments) = do

460 argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn) context) arguments

505 argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn) context) arguments

461 _ <- mapM (uncurry atomTypeVerify) $ init (zip (atomFuncType func) argTypes)

506 _ <- mapM (uncurry atomTypeVerify) $ init (zip (atomFuncType func) argTypes)

462 evaldArgs <- mapM (evalAtomExpr tupIn context) arguments

507 evaldArgs <- mapM (evalAtomExpr tupIn context) arguments

463− return $ (atomFunc func) evaldArgs

508+ return $ (evalAtomFunction func) evaldArgs

464evalAtomExpr _ context (RelationAtomExpr relExpr) = do

509evalAtomExpr _ context (RelationAtomExpr relExpr) = do

465 relAtom <- evalState (evalRelationalExpr relExpr) context

510 relAtom <- evalState (evalRelationalExpr relExpr) context

466 return $ Atom relAtom

511 return $ Atom relAtom

@@ -536,7 +581,7 @@ evalTupleExpr context attrs (TupleExpr tupMap) = do

536 tConss = typeConstructorMapping context

581 tConss = typeConstructorMapping context

537 finalAttrs = fromMaybe tupAttrs attrs

582 finalAttrs = fromMaybe tupAttrs attrs

538 --verify that the attributes match

583 --verify that the attributes match

539− when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) (traceShow (finalAttrs,tupAttrs) $ Left (TupleAttributeTypeMismatchError tupAttrs))

584+ when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ Left (TupleAttributeTypeMismatchError tupAttrs)

540 tup' <- resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup)

585 tup' <- resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup)

541 _ <- validateTuple tup' tConss

586 _ <- validateTuple tup' tConss

542 pure tup'

587 pure tup'

ProjectM36/Server.hs+1

@@ -23,6 +23,7 @@ serverDefinition = defaultProcess {

23 handleCall (\conn (ExecuteHeadName sessionId) -> handleExecuteHeadName sessionId conn),

24 handleCall (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr sessionId conn expr),

25 handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr sessionId conn expr),

26+ handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr sessionId conn expr),

26 handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr sessionId conn expr),

27 handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr sessionId conn expr),

27 handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr sessionId conn expr),

28 handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr sessionId conn expr),

28 handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies sessionId conn),

29 handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies sessionId conn),

ProjectM36/Server/EntryPoints.hs+5

@@ -18,6 +18,11 @@ handleExecuteDatabaseContextExpr sessionId conn dbexpr = do

18 ret <- liftIO $ executeDatabaseContextExpr sessionId conn dbexpr

19 reply ret conn

21+handleExecuteDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> Process (ProcessReply (Maybe RelationalError) Connection)

22+handleExecuteDatabaseContextIOExpr sessionId conn dbexpr = do

23+ ret <- executeDatabaseContextIOExpr sessionId conn dbexpr

24+ reply ret conn

25+

21handleExecuteHeadName :: SessionId -> Connection -> Process (ProcessReply (Maybe HeadName) Connection)

26handleExecuteHeadName :: SessionId -> Connection -> Process (ProcessReply (Maybe HeadName) Connection)

22handleExecuteHeadName sessionId conn = do

27handleExecuteHeadName sessionId conn = do

23 ret <- liftIO $ headName sessionId conn

28 ret <- liftIO $ headName sessionId conn

ProjectM36/Server/RemoteCallTypes.hs+2

@@ -17,6 +17,8 @@ data ExecuteRelationalExpr = ExecuteRelationalExpr SessionId RelationalExpr

17 deriving (Binary, Generic)

18data ExecuteDatabaseContextExpr = ExecuteDatabaseContextExpr SessionId DatabaseContextExpr

19 deriving (Binary, Generic)

20+data ExecuteDatabaseContextIOExpr = ExecuteDatabaseContextIOExpr SessionId DatabaseContextIOExpr

21+ deriving (Binary, Generic)

20data ExecuteGraphExpr = ExecuteGraphExpr SessionId TransactionGraphOperator

22data ExecuteGraphExpr = ExecuteGraphExpr SessionId TransactionGraphOperator

21 deriving (Binary, Generic)

23 deriving (Binary, Generic)

22data ExecuteHeadName = ExecuteHeadName SessionId

24data ExecuteHeadName = ExecuteHeadName SessionId

ProjectM36/StaticOptimizer.hs+1

@@ -153,6 +153,7 @@ applyStaticDatabaseOptimization notif@(RemoveNotification _) = pure (Right notif

153

154applyStaticDatabaseOptimization c@(AddTypeConstructor _ _) = pure (Right c)

155applyStaticDatabaseOptimization c@(RemoveTypeConstructor _) = pure (Right c)

156+applyStaticDatabaseOptimization c@(RemoveAtomFunction _) = pure (Right c)

156

157

157--optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned

158--optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned

158

159

TutorialD/Interpreter.hs+13−1

@@ -5,6 +5,7 @@ import TutorialD.Interpreter.RODatabaseContextOperator

5import TutorialD.Interpreter.DatabaseContextExpr

6import TutorialD.Interpreter.TransactionGraphOperator

7import TutorialD.Interpreter.InformationOperator

8+import TutorialD.Interpreter.DatabaseContextIOOperator

9import TutorialD.Interpreter.Import.CSV

10import TutorialD.Interpreter.Import.CSV

10import TutorialD.Interpreter.Import.TutorialD

11import TutorialD.Interpreter.Import.TutorialD

@@ -36,6 +37,7 @@ graph ops are read-write operations which change the transaction graph

36-}

37-}

37data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |

38data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |

38 DatabaseContextExprOp DatabaseContextExpr |

39 DatabaseContextExprOp DatabaseContextExpr |

40+ DatabaseContextIOExprOp DatabaseContextIOExpr |

39 InfoOp InformationOperator |

41 InfoOp InformationOperator |

40 GraphOp TransactionGraphOperator |

42 GraphOp TransactionGraphOperator |

41 ROGraphOp ROTransactionGraphOperator |

43 ROGraphOp ROTransactionGraphOperator |

@@ -48,7 +50,8 @@ interpreterParserP :: Parser ParsedOperation

48interpreterParserP = safeInterpreterParserP <|>

50interpreterParserP = safeInterpreterParserP <|>

49 liftM ImportRelVarOp (importCSVP <* eof) <|>

51 liftM ImportRelVarOp (importCSVP <* eof) <|>

50 liftM ImportDBContextOp (tutdImportP <* eof) <|>

52 liftM ImportDBContextOp (tutdImportP <* eof) <|>

51− liftM RelVarExportOp (exportCSVP <* eof)

53+ liftM RelVarExportOp (exportCSVP <* eof) <|>

54+ liftM DatabaseContextIOExprOp (parseCreateAtomFunctionExpr <* eof)

53-- the safe interpreter never reads or writes the file system

56-- the safe interpreter never reads or writes the file system

54safeInterpreterParserP :: Parser ParsedOperation

57safeInterpreterParserP :: Parser ParsedOperation

@@ -88,6 +91,15 @@ evalTutorialD sessionId conn safe expr = case expr of

88 case maybeErr of

91 case maybeErr of

89 Just err -> barf err

92 Just err -> barf err

90 Nothing -> return QuietSuccessResult

93 Nothing -> return QuietSuccessResult

94+

95+ (DatabaseContextIOExprOp execOp) -> do

96+ if needsSafe then

97+ unsafeError

98+ else do

99+ mErr <- C.executeDatabaseContextIOExpr sessionId conn execOp

100+ case mErr of

101+ Just err -> barf err

102+ Nothing -> pure QuietSuccessResult

103

92 (GraphOp execOp) -> do

104 (GraphOp execOp) -> do

93 maybeErr <- C.executeGraphExpr sessionId conn execOp

105 maybeErr <- C.executeGraphExpr sessionId conn execOp

TutorialD/Interpreter/Base.hs+3

@@ -47,6 +47,9 @@ comma = Token.comma lexer

47pipe :: Parser String

48pipe = Token.symbol lexer "|"

50+arrow :: Parser String

51+arrow = Token.symbol lexer "->"

52+

50semi :: Parser String

53semi :: Parser String

51semi = Token.semi lexer

54semi = Token.semi lexer

project-m36.cabal+14−1

@@ -13,6 +13,8 @@ Description: A relational algebra engine which can be used to persist and query

14Library

15 Build-Depends: base>=4.8 && < 4.9

16+ ,ghc >= 7.8 && <= 8.0.1

17+ ,ghc-paths

16 ,mtl

18 ,mtl

17 ,containers

19 ,containers

18 ,unordered-containers

20 ,unordered-containers

@@ -121,9 +123,12 @@ Library

121

123

122Executable tutd

124Executable tutd

123 Build-Depends: base >=4.8 && <4.9,

125 Build-Depends: base >=4.8 && <4.9,

126+ ghc >= 7.8 && <= 8.0.1,

127+ ghc-paths,

124 containers,

128 containers,

125 unordered-containers,

129 unordered-containers,

126 hashable,

130 hashable,

131+ transformers,

127 mtl,

132 mtl,

128 uuid,

133 uuid,

129 deepseq-generics,

134 deepseq-generics,

@@ -217,6 +222,7 @@ Executable tutd

217 TutorialD.Interpreter.Types

222 TutorialD.Interpreter.Types

218 main-is: TutorialD/tutd.hs

223 main-is: TutorialD/tutd.hs

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

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

225+ CC-Options: -fPIC

220 GHC-Options: -Wall

226 GHC-Options: -Wall

221 Default-Language: Haskell2010

227 Default-Language: Haskell2010

222 Default-Extensions: OverloadedStrings

228 Default-Extensions: OverloadedStrings

@@ -630,7 +636,14 @@ Test-Suite test-scripts

630 else

636 else

631 C-sources: ProjectM36/DirectoryFsync.c

637 C-sources: ProjectM36/DirectoryFsync.c

632 Build-Depends: unix

638 Build-Depends: unix

633−

639+

640+Executable dud

641+ Default-Language: Haskell2010

642+ Build-Depends: ghc >= 7.8 && <= 8.0.1, base, ghc-paths, mtl, haskeline

643+ Main-Is: test.hs

644+ GHC-Options: -Wall

645+ CPP-Options: -DGHCI

646+

634Executable project-m36-websocket-server

647Executable project-m36-websocket-server

635 Default-Language: Haskell2010

648 Default-Language: Haskell2010

636 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, persistent, aeson, path-pieces, either, conduit, http-api-data, template-haskell, persistent-template, websockets, aeson, uuid-aeson, optparse-applicative

649 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, persistent, aeson, path-pieces, either, conduit, http-api-data, template-haskell, persistent-template, websockets, aeson, uuid-aeson, optparse-applicative