a476d28 · project-m36 · git.iko.soy

project-m36.cabal+2

@@ -80,6 +80,8 @@ Library

8080 ProjectM36.TupleSet,

8181 ProjectM36.Atom,

8282 ProjectM36.AtomFunction,

83+ ProjectM36.ScriptSession,

84+ ProjectM36.DatabaseContextFunction,

8385 ProjectM36.Key,

8486 ProjectM36.FunctionalDependency,

8587 ProjectM36.DatabaseContext,

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+2−2

@@ -116,8 +116,8 @@ instance FromJSON Atom where

116116instance ToJSON Notification

117117instance FromJSON Notification

118118

119−instance ToJSON AtomFunctionBodyCompilationError

120−instance FromJSON AtomFunctionBodyCompilationError

119+instance ToJSON ScriptCompilationError

120+instance FromJSON ScriptCompilationError

121121

122122instance ToJSON RelationalError

123123instance FromJSON RelationalError

src/bin/TutorialD/Interpreter.hs+1−1

@@ -58,7 +58,7 @@ interpreterParserP = safeInterpreterParserP <|>

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

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

6060 liftM RelVarExportOp (exportCSVP <* eof) <|>

61− liftM DatabaseContextIOExprOp (addAtomFunctionExprP <* eof)

61+ liftM DatabaseContextIOExprOp (dbContextIOExprP <* eof)

6262

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

6464safeInterpreterParserP :: Parser ParsedOperation

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+13

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

3232 removeNotificationP,

3333 addTypeConstructorP,

3434 removeTypeConstructorP,

35+ executeDatabaseContextFunctionP,

3536 nothingP]

3637

3738nothingP :: Parser DatabaseContextExpr

@@ -177,6 +178,18 @@ removeAtomFunctionP :: Parser DatabaseContextExpr

177178removeAtomFunctionP = do

178179 reserved "removeatomfunction"

179180 RemoveAtomFunction <$> quotedString

181+

182+removeDatabaseContextFunctionP :: Parser DatabaseContextExpr

183+removeDatabaseContextFunctionP = do

184+ reserved "removedatabasecontextfunction"

185+ RemoveDatabaseContextFunction <$> quotedString

186+

187+executeDatabaseContextFunctionP :: Parser DatabaseContextExpr

188+executeDatabaseContextFunctionP = do

189+ reserved "execute"

190+ funcName <- identifier

191+ args <- parens (sepBy atomExprP comma)

192+ pure (ExecuteDatabaseContextFunction funcName args)

180193

181194databaseExprOpP :: Parser DatabaseContextExpr

182195databaseExprOpP = multipleDatabaseContextExprP

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

@@ -14,6 +14,19 @@ addAtomFunctionExprP = do

1414 funcType <- atomTypeSignatureP

1515 funcScript <- quotedString

1616 pure $ AddAtomFunction funcName funcType funcScript

17−

17+

1818atomTypeSignatureP :: Parser [TypeConstructor]

1919atomTypeSignatureP = sepBy typeConstructorP arrow

20+

21+addDatabaseContextFunctionExprP :: Parser DatabaseContextIOExpr

22+addDatabaseContextFunctionExprP = do

23+ reserved "adddatabasecontextfunction"

24+ funcName <- quotedString

25+ funcType <- atomTypeSignatureP

26+ funcScript <- quotedString

27+ pure $ AddDatabaseContextFunction funcName funcType funcScript

28+

29+dbContextIOExprP :: Parser DatabaseContextIOExpr

30+dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP

31+

32+

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

@@ -9,7 +9,7 @@ foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [

99

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

1111atomFunctionForName funcName funcSet = if HS.null foundFunc then

12− Left $ NoSuchTupleExprFunctionError funcName

12+ Left $ NoSuchFunctionError funcName

1313 else

1414 Right $ head $ HS.toList foundFunc

1515 where

src/lib/ProjectM36/AtomFunctionBody.hs−167

@@ -2,173 +2,6 @@

22--tools to execute an atom function body

33module ProjectM36.AtomFunctionBody where

44import ProjectM36.Base

5−import ProjectM36.Error

6−

7−import Control.Monad.IO.Class

8−import Control.Exception

9−import Data.Text hiding (map, concat, foldl)

10−import System.FilePath.Glob

11−import System.Directory

12−import System.IO.Error

13−import System.FilePath

14−import Control.Monad

15−

16−import Unsafe.Coerce

17−import GHC

18−import GHC.Paths (libdir)

19−#if __GLASGOW_HASKELL__ >= 800

20−import GHC.LanguageExtensions

21−#endif

22−import DynFlags

23−import Panic

24−import Outputable --hiding ((<>))

25−import PprTyThing

26−import Type hiding (pprTyThing)

27−

28−

29−data ScriptSession = ScriptSession {

30− hscEnv :: HscEnv,

31− atomFunctionBodyType :: Type

32− }

33−

34−data ScriptSessionError = ScriptSessionLoadError GhcException

35− deriving (Show)

36−

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

38−initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)

39−initScriptSession ghcPkgPaths = do

40− --for the sake of convenience, for developers' builds, include the local cabal sandbox package database and the cabal new-build package database

41− eHomeDir <- tryJust (guard . isDoesNotExistError) getHomeDirectory

42− let homeDir = either (const "/") id eHomeDir

43− let excHandler exc = pure $ Left (ScriptSessionLoadError exc)

44− handleGhcException excHandler $ runGhc (Just libdir) $ do

45− dflags <- getSessionDynFlags

46− let ghcVersion = projectVersion dflags

47−

48− sandboxPkgPaths <- liftIO $ liftM concat $ mapM glob [

49− "./dist-newstyle/packagedb/ghc-" ++ ghcVersion,

50− ".cabal-sandbox/*ghc-" ++ ghcVersion ++ "-packages.conf.d",

51− homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"

52− ]

53−

54− let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)

55−

56− let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted ,

57− ghcLink = LinkInMemory,

58− safeHaskell = Sf_Trustworthy,

59− safeInfer = True,

60− safeInferred = True,

61− --verbosity = 3,

62−#if __GLASGOW_HASKELL__ >= 800

63− trustFlags = map TrustPackage required_packages,

64−#endif

65− packageFlags = (packageFlags dflags) ++ packages,

66− extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf])

67− }

68− applyGopts flags = foldl gopt_set flags gopts

69− applyXopts flags = foldl xopt_set flags xopts

70−#if __GLASGOW_HASKELL__ >= 800

71− xopts = [OverloadedStrings, ExtendedDefaultRules, ImplicitPrelude, ScopedTypeVariables]

72−#else

73− xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude, Opt_ScopedTypeVariables]

74−#endif

75− gopts = [] --[Opt_DistrustAllPackages, Opt_PackageTrust]

76− required_packages = ["base",

77− "containers",

78− "Glob",

79− "directory",

80− "unordered-containers",

81− "hashable",

82− "uuid",

83− "vector",

84− "text",

85− "binary",

86− "vector-binary-instances",

87− "time",

88− "project-m36",

89− "bytestring"]

90−#if __GLASGOW_HASKELL__ >= 800

91− packages = map (\m -> ExposePackage ("-package " ++ m) (PackageArg m) (ModRenaming True [])) required_packages

92−#else

93− packages = map TrustPackage required_packages

94−#endif

95− --liftIO $ traceShowM (showSDoc dflags' (ppr packages))

96− _ <- setSessionDynFlags dflags'

97− let safeImportDecl mn = ImportDecl {

98− ideclSourceSrc = Nothing,

99− ideclName = noLoc mn,

100− ideclPkgQual = Nothing,

101− ideclSource = False,

102− ideclSafe = True,

103− ideclImplicit = False,

104− ideclQualified = False,

105− ideclAs = Nothing,

106− ideclHiding = Nothing

107− }

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

109− ["Prelude",

110− "Data.Map",

111− "ProjectM36.Base"])

112− env <- getSession

113− fType <- mkAtomFunctionBodyType

114− pure (Right (ScriptSession env fType))

115−

116−mkAtomFunctionBodyType :: Ghc Type

117−mkAtomFunctionBodyType = do

118− lBodyName <- parseName "AtomFunctionBodyType"

119− case lBodyName of

120− [] -> error "failed to parse AtomFunctionBodyType"

121− _:_:_ -> error "too many name matches"

122− bodyName:[] -> do

123− mThing <- lookupName bodyName

124− case mThing of

125− Nothing -> error "failed to find AtomFunctionBodyType"

126− Just (ATyCon tyCon) -> case synTyConRhs_maybe tyCon of

127− Just typ -> pure typ

128− Nothing -> error "AtomFunctionBodyType is not a type synonym"

129− Just _ -> error "failed to find type synonym AtomFunctionBodyType"

130−

131−addImport :: String -> Ghc ()

132−addImport moduleNam = do

133− ctx <- getContext

134− setContext ( (IIDecl $ simpleImportDecl (mkModuleName moduleNam)) : ctx )

135−

136−showType :: DynFlags -> Type -> String

137−showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)

138−

139−-- | Typecheck and validate the

140−typeCheckAtomFunctionScript :: Type -> AtomFunctionBodyScript -> Ghc (Maybe AtomFunctionBodyCompilationError)

141−typeCheckAtomFunctionScript expectedType inp = do

142− dflags <- getSessionDynFlags

143− --catch exception for SyntaxError

144− funcType <- GHC.exprType (unpack inp)

145−

146− if eqType funcType expectedType then

147− pure Nothing

148− else

149− pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))

150−

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

152−compileAtomFunctionScript :: ScriptSession -> AtomFunctionBodyScript -> Ghc (Either AtomFunctionBodyCompilationError AtomFunctionBodyType)

153−compileAtomFunctionScript (ScriptSession _ funcType) script = do

154− let sScript = unpack script

155− mErr <- typeCheckAtomFunctionScript funcType script

156− case mErr of

157− Just err -> pure (Left err)

158− Nothing -> do

159− --catch exception here

160− --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.

161− -- we can't use dynCompileExpr here because

162− func <- compileExpr sScript

163− pure $ Right (unsafeCoerce func)

164−

165−catchCompileException :: MonadIO m => IO a -> m (Either AtomFunctionBodyCompilationError a)

166−catchCompileException m = liftIO $ do

167− mres <- try m

168− case mres of

169− Left (err :: SomeException) -> do

170− pure (Left (OtherScriptCompilationError (show err)))

171− Right res -> pure (Right res)

1725

1736compiledAtomFunctionBody :: AtomFunctionBodyType -> AtomFunctionBody

1747compiledAtomFunctionBody func = AtomFunctionBody Nothing func

src/lib/ProjectM36/Base.hs+38−1

@@ -283,6 +283,7 @@ data DatabaseContext = DatabaseContext {

283283 inclusionDependencies :: InclusionDependencies,

284284 relationVariables :: RelationVariables,

285285 atomFunctions :: AtomFunctions,

286+ dbcFunctions :: DatabaseContextFunctions,

286287 notifications :: Notifications,

287288 typeConstructorMapping :: TypeConstructorMapping

288289 }

@@ -318,11 +319,16 @@ data DatabaseContextExpr =

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

319320 RemoveAtomFunction AtomFunctionName |

320321

322+ RemoveDatabaseContextFunction DatabaseContextFunctionName |

323+

324+ ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExpr] |

325+

321326 MultipleExpr [DatabaseContextExpr]

322327 deriving (Show, Eq, Binary, Generic)

323328

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

325−data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript

330+data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |

331+ AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript

326332 deriving (Show, Eq, Generic, Binary)

327333

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

@@ -488,4 +494,35 @@ data MergeStrategy =

488494 SelectedBranchMergeStrategy HeadName

489495 deriving (Eq, Show, Binary, Generic, NFData)

490496

497+type DatabaseContextFunctionName = StringType

498+

499+type DatabaseContextFunctionBodyScript = StringType

500+

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

502+

503+data DatabaseContextFunctionBody = DatabaseContextFunctionBody (Maybe DatabaseContextFunctionBodyScript) DatabaseContextFunctionBodyType

491504

505+data DatabaseContextFunction = DatabaseContextFunction {

506+ dbcFuncName :: DatabaseContextFunctionName,

507+ dbcFuncType :: [AtomType],

508+ dbcFuncBody :: DatabaseContextFunctionBody

509+ }

510+

511+type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction

512+

513+instance Hashable DatabaseContextFunction where

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

515+

516+instance Eq DatabaseContextFunction where

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

518+ (DatabaseContextFunctionBody mScript2 _) = dbcFuncBody f2 in

519+ if dbcFuncName f1 == dbcFuncName f2 then

520+ if isJust mScript1 then

521+ if mScript1 == mScript2 then

522+ True

523+ else

524+ False

525+ else

526+ True

527+ else

528+ False

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

@@ -102,8 +102,10 @@ import ProjectM36.Notifications

102102import ProjectM36.Server.RemoteCallTypes

103103import qualified ProjectM36.DisconnectedTransaction as Discon

104104import ProjectM36.Relation (typesAsRelation)

105−import ProjectM36.AtomFunctionBody (initScriptSession, ScriptSession)

105+import ProjectM36.ScriptSession (initScriptSession, ScriptSession)

106106import qualified ProjectM36.Relation as R

107+import qualified ProjectM36.DatabaseContext as DBC

108+

107109import Network.Transport (Transport(closeTransport))

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

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

@@ -641,7 +643,7 @@ executeTransGraphRelationalExpr _ (InProcessConnection conf) tgraphExpr = excEit

641643 graph <- readTVar graphTvar

642644 case evalTransGraphRelationalExpr tgraphExpr graph of

643645 Left err -> pure (Left err)

644− Right relExpr -> case evalState (RE.evalRelationalExpr relExpr) (RE.mkRelationalExprState RE.emptyDatabaseContext) of

646+ Right relExpr -> case evalState (RE.evalRelationalExpr relExpr) (RE.mkRelationalExprState DBC.empty) of

645647 Left err -> pure (Left err)

646648 Right rel -> pure (force (Right rel))

647649executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr)

src/lib/ProjectM36/DatabaseContext.hs+3

@@ -4,6 +4,7 @@ import qualified Data.Map as M

44import qualified Data.HashSet as HS

55import ProjectM36.DataTypes.Basic

66import ProjectM36.AtomFunctions.Basic

7+import ProjectM36.DatabaseContextFunction

78import ProjectM36.Relation

89

910empty :: DatabaseContext

@@ -11,6 +12,7 @@ empty = DatabaseContext { inclusionDependencies = M.empty,

1112 relationVariables = M.empty,

1213 notifications = M.empty,

1314 atomFunctions = HS.empty,

15+ dbcFunctions = HS.empty,

1416 typeConstructorMapping = [] }

1517

1618-- | convert an existing database context into its constituent expression.

@@ -27,6 +29,7 @@ basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

2729 relationVariables = M.fromList [("true", relationTrue),

2830 ("false", relationFalse)],

2931 atomFunctions = basicAtomFunctions,

32+ dbcFunctions = basicDatabaseContextFunctions,

3033 notifications = M.empty,

3134 typeConstructorMapping = basicTypeConstructorMapping

3235 }

src/lib/ProjectM36/DatabaseContextFunction.hsnew file+33

@@ -0,0 +1,33 @@

1+module ProjectM36.DatabaseContextFunction where

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

3+import ProjectM36.Base

4+import ProjectM36.Error

5+import qualified Data.HashSet as HS

6+import qualified Data.Map as M

7+

8+emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction

9+emptyDatabaseContextFunction name = DatabaseContextFunction {

10+ dbcFuncName = name,

11+ dbcFuncType = [],

12+ dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> ctx)

13+ }

14+

15+databaseContextFunctionForName :: DatabaseContextFunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction

16+databaseContextFunctionForName funcName funcs = if HS.null foundFunc then

17+ Left $ NoSuchFunctionError funcName

18+ else

19+ Right (head (HS.toList foundFunc))

20+ where

21+ foundFunc = HS.filter (\(DatabaseContextFunction name _ _) -> name == funcName) funcs

22+

23+evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> DatabaseContext

24+evalDatabaseContextFunction func args ctx = case dbcFuncBody func of

25+ (DatabaseContextFunctionBody _ f) -> f args ctx

26+

27+basicDatabaseContextFunctions :: DatabaseContextFunctions

28+basicDatabaseContextFunctions = HS.fromList [

29+ DatabaseContextFunction { dbcFuncName = "deleteAll",

30+ dbcFuncType = [],

31+ dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> ctx { relationVariables = M.empty })

32+ }

33+ ]

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

@@ -10,7 +10,7 @@ import qualified Data.Map as M

1010import qualified Data.Set as S

1111

1212dateExamples :: DatabaseContext

13−dateExamples = DatabaseContext { inclusionDependencies = dateIncDeps,

13+dateExamples = empty { inclusionDependencies = dateIncDeps,

1414 relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,

1515 notifications = M.empty,

1616 atomFunctions = basicAtomFunctions,

src/lib/ProjectM36/Error.hs+10−10

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

3939 | NoSuchSessionError TransactionId

4040 | FailedToFindTransactionError TransactionId

4141 | TransactionIdInUseError TransactionId

42− | NoSuchTupleExprFunctionError AtomFunctionName

42+ | NoSuchFunctionError AtomFunctionName

4343 | NoSuchTypeConstructorName TypeConstructorName

4444 | TypeConstructorAtomTypeMismatch TypeConstructorName AtomType

4545 | AtomTypeMismatchError AtomType AtomType

@@ -54,9 +54,9 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

5454 | AtomTypeNameInUseError AtomTypeName

5555 | IncompletelyDefinedAtomTypeWithConstructorError

5656 | AtomTypeNameNotInUseError AtomTypeName

57− | AtomFunctionNameInUseError AtomFunctionName

58− | AtomFunctionNameNotInUseError AtomFunctionName

59− | AtomFunctionArgumentCountMismatch Int Int

57+ | FunctionNameInUseError AtomFunctionName

58+ | FunctionNameNotInUseError AtomFunctionName

59+ | FunctionArgumentCountMismatch Int Int

6060 | NoSuchDataConstructorError DataConstructorName

6161 | NoSuchTypeConstructorError TypeConstructorName

6262 | InvalidAtomTypeName AtomTypeName

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

7272 | ExportError T.Text

7373 | UnhandledExceptionError String

7474 | MergeTransactionError MergeError

75− | AtomFunctionBodyScriptError AtomFunctionBodyCompilationError

75+ | ScriptError ScriptCompilationError

7676

7777 | SubschemaNameInUseError SchemaName

7878 | SubschemaNameNotInUseError SchemaName

@@ -110,11 +110,11 @@ data MergeError = SelectedHeadMismatchMergeError |

110110

111111instance NFData MergeError where rnf = genericRnf

112112

113−data AtomFunctionBodyCompilationError = TypeCheckCompilationError String String | --expected, got

114− SyntaxErrorCompilationError String |

115− ScriptCompilationDisabledError |

116− OtherScriptCompilationError String

117− deriving (Show,Eq, Generic, Binary, Typeable, NFData)

113+data ScriptCompilationError = TypeCheckCompilationError String String | --expected, got

114+ SyntaxErrorCompilationError String |

115+ ScriptCompilationDisabledError |

116+ OtherScriptCompilationError String

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

118118

119119data SchemaError = RelVarReferencesMissing (S.Set RelVarName) |

120120 RelVarInReferencedMoreThanOnce RelVarName |

src/lib/ProjectM36/RelationalExpression.hs+82−18

@@ -6,9 +6,11 @@ import ProjectM36.TupleSet

66import ProjectM36.Base

77import ProjectM36.Error

88import ProjectM36.AtomType

9−import ProjectM36.AtomFunctionBody

9+import ProjectM36.Attribute (emptyAttributes)

10+import ProjectM36.ScriptSession

1011import ProjectM36.DataTypes.Primitive

1112import ProjectM36.AtomFunction

13+import ProjectM36.DatabaseContextFunction

1214import qualified ProjectM36.Attribute as A

1315import qualified Data.Map as M

1416import qualified Data.HashSet as HS

@@ -185,16 +187,6 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do

185187 Left err -> pure (Left err)

186188 Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel

187189

188−emptyDatabaseContext :: DatabaseContext

189−emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,

190− relationVariables = M.empty,

191− atomFunctions = HS.empty,

192− notifications = M.empty,

193− typeConstructorMapping = []

194− }

195−

196−

197−

198190--helper function to process relation variable creation/assignment

199191setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)

200192setRelVar relVarName rel = do

@@ -376,20 +368,61 @@ evalContextExpr (RemoveAtomFunction funcName) = do

376368 put (currentContext {atomFunctions = updatedFuncs })

377369 pure Nothing

378370 else

379− pure (Just (AtomFunctionNameNotInUseError funcName))

371+ pure (Just (FunctionNameNotInUseError funcName))

372+

373+evalContextExpr (RemoveDatabaseContextFunction funcName) = do

374+ context <- get

375+ let dudFunc = emptyDatabaseContextFunction funcName

376+ dbcFuncs = dbcFunctions context

377+ if HS.member dudFunc dbcFuncs then do

378+ let updatedFuncs = HS.delete dudFunc dbcFuncs

379+ put (context { dbcFunctions = updatedFuncs })

380+ pure Nothing

381+ else

382+ pure (Just (FunctionNameNotInUseError funcName))

383+

384+evalContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

385+ context <- get

386+ --resolve atom arguments

387+ let relExprState = mkRelationalExprState context

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

389+ eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

390+ case eFunc of

391+ Left err -> pure (Just err)

392+ Right func -> do

393+ let expectedArgCount = length (dbcFuncType func)

394+ actualArgCount = length atomTypes

395+ safeInit [_] = []

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

397+ safeInit (_:xs) = safeInit xs

398+ if expectedArgCount /= actualArgCount then

399+ pure (Just (FunctionArgumentCountMismatch expectedArgCount actualArgCount))

400+ else do

401+ {-

402+ mapM_ (\(expType, actType) -> case atomTypeVerify expType actType of

403+ Left err -> pure (Just err)

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

405+ -}

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

407+ if length (lefts eAtomArgs) > 1 then

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

409+ else do

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

411+ put newContext

412+ pure Nothing

380413

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

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

383416 case mScriptSession of

384− Nothing -> pure (Left (AtomFunctionBodyScriptError ScriptCompilationDisabledError))

417+ Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))

385418 Just scriptSession -> do

386419 res <- try $ runGhc (Just libdir) $ do

387420 setSession (hscEnv scriptSession)

388421 let atomFuncs = atomFunctions currentContext

389422 --compile the function

390− eCompiledFunc <- compileAtomFunctionScript scriptSession script

423+ eCompiledFunc <- compileScript (atomFunctionBodyType scriptSession) script

391424 pure $ case eCompiledFunc of

392− Left err -> Left (AtomFunctionBodyScriptError err)

425+ Left err -> Left (ScriptError err)

393426 Right compiledFunc -> do

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

395428 let updatedFuncs = HS.insert newAtomFunc atomFuncs

@@ -400,14 +433,45 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcNam

400433

401434 -- check if the name is already in use

402435 if HS.member funcName (HS.map atomFuncName atomFuncs) then

403− Left (AtomFunctionNameInUseError funcName)

436+ Left (FunctionNameInUseError funcName)

437+ else do

438+ Right newContext

439+ case res of

440+ Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))

441+ Right eContext -> case eContext of

442+ Left err -> pure (Left err)

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

444+

445+evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) = do

446+ case mScriptSession of

447+ Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))

448+ Just scriptSession -> do

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

450+ setSession (hscEnv scriptSession)

451+ eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script

452+ pure $ case eCompiledFunc of

453+ Left err -> Left (ScriptError err)

454+ Right compiledFunc -> do

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

456+ let updatedDBCFuncs = HS.insert newDBCFunc (dbcFunctions currentContext)

457+ newContext = currentContext { dbcFunctions = updatedDBCFuncs }

458+ dbcFuncs = dbcFunctions currentContext

459+ newDBCFunc = DatabaseContextFunction {

460+ dbcFuncName = funcName,

461+ dbcFuncType = funcAtomType,

462+ dbcFuncBody = DatabaseContextFunctionBody (Just script) compiledFunc

463+ }

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

465+ if HS.member funcName (HS.map dbcFuncName dbcFuncs) then

466+ Left (FunctionNameInUseError funcName)

404467 else do

405468 Right newContext

406469 case res of

407− Left (exc :: SomeException) -> pure $ Left (AtomFunctionBodyScriptError (OtherScriptCompilationError (show exc)))

470+ Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))

408471 Right eContext -> case eContext of

409472 Left err -> pure (Left err)

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

474+

411475

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

413477updateTupleWithAtomExprs exprMap context tupIn = do

@@ -568,7 +632,7 @@ evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do

568632 safeInit [] = [] -- different behavior from normal init

569633 safeInit (_:xs) = safeInit xs

570634 if expectedArgCount /= actualArgCount then

571− throwE (AtomFunctionArgumentCountMismatch expectedArgCount actualArgCount)

635+ throwE (FunctionArgumentCountMismatch expectedArgCount actualArgCount)

572636 else do

573637 _ <- mapM (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes))

574638 evaldArgs <- mapM (\arg -> liftE (evalAtomExpr tupIn arg)) arguments

src/lib/ProjectM36/ScriptSession.hsnew file+161

@@ -0,0 +1,161 @@

1+module ProjectM36.ScriptSession where

2+

3+import ProjectM36.Error

4+

5+import Control.Exception

6+import Control.Monad

7+import System.IO.Error

8+import System.Directory

9+import Control.Monad.IO.Class

10+import System.FilePath.Glob

11+import System.FilePath

12+import Data.Text (Text, unpack)

13+

14+import GHC

15+import GHC.Paths (libdir)

16+#if __GLASGOW_HASKELL__ >= 800

17+import GHC.LanguageExtensions

18+#endif

19+import DynFlags

20+import Panic

21+import Outputable --hiding ((<>))

22+import PprTyThing

23+import Unsafe.Coerce

24+import Type hiding (pprTyThing)

25+

26+data ScriptSession = ScriptSession {

27+ hscEnv :: HscEnv,

28+ atomFunctionBodyType :: Type,

29+ dbcFunctionBodyType :: Type

30+ }

31+

32+data ScriptSessionError = ScriptSessionLoadError GhcException

33+ deriving (Show)

34+

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

36+initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)

37+initScriptSession ghcPkgPaths = do

38+ --for the sake of convenience, for developers' builds, include the local cabal sandbox package database and the cabal new-build package database

39+ eHomeDir <- tryJust (guard . isDoesNotExistError) getHomeDirectory

40+ let homeDir = either (const "/") id eHomeDir

41+ let excHandler exc = pure $ Left (ScriptSessionLoadError exc)

42+ handleGhcException excHandler $ runGhc (Just libdir) $ do

43+ dflags <- getSessionDynFlags

44+ let ghcVersion = projectVersion dflags

45+

46+ sandboxPkgPaths <- liftIO $ liftM concat $ mapM glob [

47+ "./dist-newstyle/packagedb/ghc-" ++ ghcVersion,

48+ ".cabal-sandbox/*ghc-" ++ ghcVersion ++ "-packages.conf.d",

49+ homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"

50+ ]

51+

52+ let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)

53+

54+ let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted ,

55+ ghcLink = LinkInMemory,

56+ safeHaskell = Sf_Trustworthy,

57+ safeInfer = True,

58+ safeInferred = True,

59+ --verbosity = 3,

60+#if __GLASGOW_HASKELL__ >= 800

61+ trustFlags = map TrustPackage required_packages,

62+#endif

63+ packageFlags = (packageFlags dflags) ++ packages,

64+ extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf])

65+ }

66+ applyGopts flags = foldl gopt_set flags gopts

67+ applyXopts flags = foldl xopt_set flags xopts

68+#if __GLASGOW_HASKELL__ >= 800

69+ xopts = [OverloadedStrings, ExtendedDefaultRules, ImplicitPrelude, ScopedTypeVariables]

70+#else

71+ xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude, Opt_ScopedTypeVariables]

72+#endif

73+ gopts = [] --[Opt_DistrustAllPackages, Opt_PackageTrust]

74+ required_packages = ["base",

75+ "containers",

76+ "Glob",

77+ "directory",

78+ "unordered-containers",

79+ "hashable",

80+ "uuid",

81+ "vector",

82+ "text",

83+ "binary",

84+ "vector-binary-instances",

85+ "time",

86+ "project-m36",

87+ "bytestring"]

88+#if __GLASGOW_HASKELL__ >= 800

89+ packages = map (\m -> ExposePackage ("-package " ++ m) (PackageArg m) (ModRenaming True [])) required_packages

90+#else

91+ packages = map TrustPackage required_packages

92+#endif

93+ --liftIO $ traceShowM (showSDoc dflags' (ppr packages))

94+ _ <- setSessionDynFlags dflags'

95+ let safeImportDecl mn = ImportDecl {

96+ ideclSourceSrc = Nothing,

97+ ideclName = noLoc mn,

98+ ideclPkgQual = Nothing,

99+ ideclSource = False,

100+ ideclSafe = True,

101+ ideclImplicit = False,

102+ ideclQualified = False,

103+ ideclAs = Nothing,

104+ ideclHiding = Nothing

105+ }

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

107+ ["Prelude",

108+ "Data.Map",

109+ "ProjectM36.Base"])

110+ env <- getSession

111+ atomFuncType <- mkTypeForName "AtomFunctionBodyType"

112+ dbcFuncType <- mkTypeForName "DatabaseContextFunctionBodyType"

113+ pure (Right (ScriptSession env atomFuncType dbcFuncType))

114+

115+addImport :: String -> Ghc ()

116+addImport moduleNam = do

117+ ctx <- getContext

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

119+

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

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

122+

123+mkTypeForName :: String -> Ghc Type

124+mkTypeForName name = do

125+ lBodyName <- parseName name

126+ case lBodyName of

127+ [] -> error ("failed to parse " ++ name)

128+ _:_:_ -> error "too many name matches"

129+ bodyName:[] -> do

130+ mThing <- lookupName bodyName

131+ case mThing of

132+ Nothing -> error ("failed to find " ++ name)

133+ Just (ATyCon tyCon) -> case synTyConRhs_maybe tyCon of

134+ Just typ -> pure typ

135+ Nothing -> error (name ++ " is not a type synonym")

136+ Just _ -> error ("failed to find type synonym " ++ name)

137+

138+compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)

139+compileScript funcType script = do

140+ let sScript = unpack script

141+ mErr <- typeCheckScript funcType script

142+ case mErr of

143+ Just err -> pure (Left err)

144+ Nothing -> do

145+ --catch exception here

146+ --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.

147+ -- we can't use dynCompileExpr here because

148+ func <- compileExpr sScript

149+ pure $ Right (unsafeCoerce func)

150+

151+typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)

152+typeCheckScript expectedType inp = do

153+ dflags <- getSessionDynFlags

154+ --catch exception for SyntaxError

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

156+

157+ if eqType funcType expectedType then

158+ pure Nothing

159+ else

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

161+

src/lib/ProjectM36/StaticOptimizer.hs+2

@@ -161,6 +161,8 @@ applyStaticDatabaseOptimization notif@(RemoveNotification _) = pure (Right notif

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

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

163163applyStaticDatabaseOptimization c@(RemoveAtomFunction _) = pure (Right c)

164+applyStaticDatabaseOptimization c@(RemoveDatabaseContextFunction _) = pure (Right c)

165+applyStaticDatabaseOptimization c@(ExecuteDatabaseContextFunction _ _) = pure (Right c)

164166

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

166168

src/lib/ProjectM36/Transaction/Persist.hs+2−1

@@ -60,7 +60,8 @@ readTransaction dbdir transId = do

6060 relationVariables = relvars,

6161 typeConstructorMapping = typeCons,

6262 notifications = M.empty,

63− atomFunctions = atomFuncs }

63+ atomFunctions = atomFuncs,

64+ dbcFunctions = undefined }

6465 newSchemas = Schemas newContext sschemas

6566 return $ Right $ Transaction transId transInfo newSchemas

6667

src/lib/ProjectM36/TransactionGraph.hs+8−1

@@ -427,7 +427,14 @@ createUnionMergeTransaction newId strategy graph (t1,t2) = do

427427 notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)

428428 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)

429429 -- TODO: add merge of subschemas

430− let newContext = DatabaseContext incDeps relVars atomFuncs notifs types

430+ let newContext = DatabaseContext {

431+ inclusionDependencies = incDeps,

432+ relationVariables = relVars,

433+ atomFunctions = atomFuncs,

434+ dbcFunctions = undefined,

435+ notifications = notifs,

436+ typeConstructorMapping = types

437+ }

431438 newSchemas = Schemas newContext (subschemas t1)

432439 pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) newSchemas)

433440