f4794d3 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP add dbc function errors

commitf4794d36192642a8bc462854c5beff70bbafa822 authorAgentM <agentm@themactionfaction.com> dateSun 9 Apr 2017, 15:37 (10 years ago) parentaf92f0d

14 files changed+67−35

compare with master

unifiedsplit

project-m36.cabal+1

@@ -82,6 +82,7 @@ Library

8282 ProjectM36.AtomFunction,

8383 ProjectM36.ScriptSession,

8484 ProjectM36.DatabaseContextFunction,

85+ ProjectM36.DatabaseContextFunctionError,

8586 ProjectM36.Key,

8687 ProjectM36.FunctionalDependency,

8788 ProjectM36.DatabaseContext,

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+4

@@ -7,6 +7,7 @@ import ProjectM36.Base

77import ProjectM36.Error

88import ProjectM36.DataTypes.Primitive

99import ProjectM36.IsomorphicSchema

10+import ProjectM36.DatabaseContextFunctionError

1011

1112import Control.Monad

1213import Data.Aeson

@@ -128,6 +129,9 @@ instance FromJSON SchemaError

128129instance ToJSON MergeError

129130instance FromJSON MergeError

130131

132+instance ToJSON DatabaseContextFunctionError

133+instance FromJSON DatabaseContextFunctionError

134+

131135instance ToJSON MergeStrategy

132136instance FromJSON MergeStrategy

133137

src/bin/TutorialD/Interpreter/Types.hs+6−2

@@ -38,9 +38,13 @@ typeConstructorP :: Parser TypeConstructor

3838typeConstructorP = primitiveTypeConstructorP <|>

3939 ADTypeConstructor <$> capitalizedIdentifier <*> many typeConstructorArgP

4040

41+monoTypeConstructorP :: Parser TypeConstructor

42+monoTypeConstructorP = ADTypeConstructor <$> capitalizedIdentifier <*> pure []

43+

4144typeConstructorArgP :: Parser TypeConstructorArg

42−typeConstructorArgP = TypeConstructorArg <$> typeConstructorP <|>

43− TypeConstructorTypeVarArg <$> uncapitalizedIdentifier

45+typeConstructorArgP = TypeConstructorArg <$> monoTypeConstructorP <|>

46+ parens (TypeConstructorArg <$> typeConstructorP) <|>

47+ TypeConstructorTypeVarArg <$> uncapitalizedIdentifier

4448

4549

4650

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

@@ -31,4 +31,5 @@ compiledAtomFunction name aType body = AtomFunction { atomFuncName = name,

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

3232evalAtomFunction :: AtomFunction -> [Atom] -> Atom

3333evalAtomFunction func args = case atomFuncBody func of

34− (AtomFunctionBody _ f) -> f args

34+ (AtomFunctionBody _ f) -> f args

35+

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

@@ -1,6 +1,8 @@

11{-# LANGUAGE ExistentialQuantification,BangPatterns,DeriveGeneric,DeriveAnyClass, TypeSynonymInstances, FlexibleInstances #-}

22{-# OPTIONS_GHC -fno-warn-orphans #-}

33module ProjectM36.Base where

4+import ProjectM36.DatabaseContextFunctionError

46import qualified Data.Map as M

57import qualified Data.HashSet as HS

68import Data.Hashable (Hashable, hashWithSalt)

@@ -20,7 +22,6 @@ import Data.Time.Calendar (Day,toGregorian,fromGregorian)

2022import Data.Hashable.Time ()

2123import Data.Typeable

2224import Data.ByteString (ByteString)

23−import Data.Maybe (isJust)

2425

2526type StringType = Text

2627

@@ -484,7 +485,7 @@ type DatabaseContextFunctionName = StringType

484485

485486type DatabaseContextFunctionBodyScript = StringType

486487

487−type DatabaseContextFunctionBodyType = [Atom] -> DatabaseContext -> DatabaseContext

488+type DatabaseContextFunctionBodyType = [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext

488489

489490data DatabaseContextFunctionBody = DatabaseContextFunctionBody (Maybe DatabaseContextFunctionBodyScript) DatabaseContextFunctionBodyType

490491

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

@@ -316,15 +316,15 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghc

316316 err <- setupDatabaseDir sync dbdir freshGraph

317317 case err of

318318 Just err' -> return $ Left (SetupDatabaseDirectoryError err')

319− Nothing -> do

320− graph <- transactionGraphLoad dbdir emptyTransactionGraph

319+ Nothing -> do

320+ mScriptSession <- createScriptSession ghcPkgPaths

321+ graph <- transactionGraphLoad dbdir emptyTransactionGraph mScriptSession

321322 case graph of

322323 Left err' -> return $ Left (SetupDatabaseDirectoryError err')

323324 Right graph' -> do

324325 tvarGraph <- newTVarIO graph'

325326 sessions <- STMMap.newIO

326327 clientNodes <- STMSet.newIO

327− mScriptSession <- createScriptSession ghcPkgPaths

328328 (localNode, transport) <- createLocalNode

329329 let conn = InProcessConnection (InProcessConnectionConf {

330330 ipPersistenceStrategy = strat,

src/lib/ProjectM36/DatabaseContextFunction.hs+6−4

@@ -9,7 +9,7 @@ emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFu

99emptyDatabaseContextFunction name = DatabaseContextFunction {

1010 dbcFuncName = name,

1111 dbcFuncType = [],

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

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

1313 }

1414

1515databaseContextFunctionForName :: DatabaseContextFunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction

@@ -20,14 +20,16 @@ databaseContextFunctionForName funcName funcs = if HS.null foundFunc then

2020 where

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

2222

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

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

2424evalDatabaseContextFunction func args ctx = case dbcFuncBody func of

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

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

26+ Left err -> Left (DatabaseContextFunctionUserError err)

27+ Right c -> pure c

2628

2729basicDatabaseContextFunctions :: DatabaseContextFunctions

2830basicDatabaseContextFunctions = HS.fromList [

2931 DatabaseContextFunction { dbcFuncName = "deleteAll",

3032 dbcFuncType = [],

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

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

3234 }

3335 ]

src/lib/ProjectM36/DatabaseContextFunctionError.hsnew file+8

@@ -0,0 +1,8 @@

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

2+module ProjectM36.DatabaseContextFunctionError where

3+import GHC.Generics

4+import Data.Binary

5+import Control.DeepSeq

7+data DatabaseContextFunctionError = DatabaseContextFunctionUserError String

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

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

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

11{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

22module ProjectM36.Error where

33import ProjectM36.Base

4+import ProjectM36.DatabaseContextFunctionError

45import qualified Data.Set as S

56import Control.DeepSeq (NFData, rnf)

67import Control.DeepSeq.Generics (genericRnf)

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

7374 | UnhandledExceptionError String

7475 | MergeTransactionError MergeError

7576 | ScriptError ScriptCompilationError

77+ | DatabaseContextFunctionUserError DatabaseContextFunctionError

7678

7779 | SubschemaNameInUseError SchemaName

7880 | SubschemaNameNotInUseError SchemaName

@@ -82,10 +84,8 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

8284 | ImproperDatabaseStateError

8385

8486 | MultipleErrors [RelationalError]

85− deriving (Show,Eq,Generic,Binary,Typeable)

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

8688

87−instance NFData RelationalError where rnf = genericRnf

88−

8989data PersistenceError = InvalidDirectoryError FilePath |

9090 MissingTransactionError TransactionId

9191 deriving (Show, Eq, Generic)

src/lib/ProjectM36/RelationalExpression.hs+7−8

@@ -374,7 +374,6 @@ evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do

374374 context <- get

375375 let dudFunc = emptyDatabaseContextFunction funcName

376376 dbcFuncs = dbcFunctions context

377− names = HS.map dbcFuncName dbcFuncs

378377 if HS.member dudFunc dbcFuncs then do

379378 let updatedFuncs = HS.delete dudFunc dbcFuncs

380379 put (context { dbcFunctions = updatedFuncs })

@@ -411,9 +410,9 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) =

411410 else if length typeErrors > 0 then

412411 pure (Just (someErrors typeErrors))

413412 else do

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

415− put newContext

416− pure Nothing

413+ case evalDatabaseContextFunction func (rights eAtomArgs) context of

414+ Left err -> pure (Just err)

415+ Right newContext -> put newContext >> pure Nothing

417416

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

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

@@ -451,12 +450,12 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct

451450 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))

452451 Just scriptSession -> do

453452 --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext

454− let last2Args = take 2 (reverse funcType)

453+ let last2Args = reverse (take 2 (reverse funcType))

455454 atomArgs = take (length funcType - 2) funcType

456− dbContextTypeCons = ADTypeConstructor "DatabaseContext" []

457− expectedType = "DatabaseContextExpr -> DatabaseContextExpr"

455+ dbContextTypeCons = ADTypeConstructor "Either" [TypeConstructorArg (ADTypeConstructor "DatabaseContextFunctionError" []), TypeConstructorArg (ADTypeConstructor "DatabaseContext" [])]

456+ expectedType = "DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"

458457 actualType = show funcType

459− if last2Args /= replicate 2 dbContextTypeCons then

458+ if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then

460459 pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))

461460 else do

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

src/lib/ProjectM36/ScriptSession.hs+1

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

110110 "Control.Monad.State",

111111 "ProjectM36.Base",

112112 "ProjectM36.Relation",

113+ "ProjectM36.DatabaseContextFunctionError",

113114 "ProjectM36.RelationalExpression"])

114115 env <- getSession

115116 atomFuncType <- mkTypeForName "AtomFunctionBodyType"

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

@@ -54,6 +54,7 @@ readTransaction dbdir transId = do

5454 incDeps <- readIncDeps transDir

5555 typeCons <- readTypeConstructorMapping transDir

5656 sschemas <- readSubschemas transDir

57+ --dbcFuncs <-

5758 --atomFuncs <- readAtomFuncs transDir -- not yet supported since there is no bytecode to serialize yet

5859 let atomFuncs = basicAtomFunctions

5960 let newContext = DatabaseContext { inclusionDependencies = incDeps,

@@ -61,7 +62,7 @@ readTransaction dbdir transId = do

6162 typeConstructorMapping = typeCons,

6263 notifications = M.empty,

6364 atomFunctions = atomFuncs,

64− dbcFunctions = undefined }

65+ dbcFunctions = HS.empty }

6566 newSchemas = Schemas newContext sschemas

6667 return $ Right $ Transaction transId transInfo newSchemas

6768

src/lib/ProjectM36/TransactionGraph/Persist.hs+6−5

@@ -4,6 +4,7 @@ import ProjectM36.TransactionGraph

44import ProjectM36.Transaction

55import ProjectM36.Transaction.Persist

66import ProjectM36.Base

7+import ProjectM36.ScriptSession

78import ProjectM36.Persist (writeFileSync, renameSync, DiskSync)

89import System.Directory

910import System.FilePath

@@ -97,8 +98,8 @@ load any transactions which are not already part of the incoming transaction gra

9798-}

9899

99100--ALERT I need to figure out how to manage the transaction heads (branch names)

100−transactionGraphLoad :: FilePath -> TransactionGraph -> IO (Either PersistenceError TransactionGraph)

101−transactionGraphLoad dbdir graphIn = do

101+transactionGraphLoad :: FilePath -> TransactionGraph -> Maybe ScriptSession -> IO (Either PersistenceError TransactionGraph)

102+transactionGraphLoad dbdir graphIn mScriptSession = do

102103 --optimization: perform tail-bisection search to find last-recorded transaction in the existing stream- replay the rest

103104 --read in all missing transactions from transaction directories and add to graph

104105 uuidInfo <- readGraphTransactionIdFile dbdir

@@ -108,7 +109,7 @@ transactionGraphLoad dbdir graphIn = do

108109 Right info -> do

109110 let folder = \eitherGraph transId -> case eitherGraph of

110111 Left err -> return $ Left err

111− Right graph -> readTransactionIfNecessary dbdir transId graph

112+ Right graph -> readTransactionIfNecessary dbdir transId mScriptSession graph

112113 loadedGraph <- foldM folder (Right graphIn) (map fst info)

113114 case loadedGraph of

114115 Left err -> return $ Left err

@@ -120,8 +121,8 @@ transactionGraphLoad dbdir graphIn = do

120121{-

121122if the transaction with the TransactionId argument is not yet part of the graph, then read the transaction and add it - this does not update the heads

122123-}

123−readTransactionIfNecessary :: FilePath -> TransactionId -> TransactionGraph -> IO (Either PersistenceError TransactionGraph)

124−readTransactionIfNecessary dbdir transId graphIn = do

124+readTransactionIfNecessary :: FilePath -> TransactionId -> Maybe ScriptSession -> TransactionGraph -> IO (Either PersistenceError TransactionGraph)

125+readTransactionIfNecessary dbdir transId mScriptSession graphIn = do

125126 if isRight $ transactionForId transId graphIn then

126127 --the transaction is already known and loaded- done

127128 return $ Right graphIn

test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs+15−6

@@ -8,18 +8,19 @@ import qualified Data.Text as T

88main :: IO ()

99main = do

1010 tcounts <- runTestTT (TestList [testBasicDBCFunction,

11− testErrorDBCFunction,

11+ testErrorDBCFunction,

12+ testExceptionDBCFunction,

1213 testDBCFunctionWithAtomArguments

1314 ])

1415 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

1516

1617{-

17−adddatabasecontextfunction "addtruerv" DatabaseContext -> DatabaseContext """(\[] ctx -> execState (evalContextExpr (Assign "true2" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""

18+adddatabasecontextfunction "addtruerv" DatabaseContext -> DatabaseContext """(\[] ctx -> execState (evalDatabaseContextExpr (Assign "true2" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""

1819-}

1920testBasicDBCFunction :: Test

2021testBasicDBCFunction = TestCase $ do

2122 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

22− let addfunc = "adddatabasecontextfunction \"addTrue2\" DatabaseContext -> DatabaseContext \"\"\"(\\[] ctx -> execState (evalContextExpr (Assign \"true2\" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext\"\"\""

23+ let addfunc = "adddatabasecontextfunction \"addTrue2\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] ctx -> pure $ execState (evalDatabaseContextExpr (Assign \"true2\" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""

2324 executeTutorialD sess conn addfunc

2425 executeTutorialD sess conn "execute addTrue2()"

2526 let true2Expr = RelationVariable "true2" ()

@@ -28,20 +29,28 @@ testBasicDBCFunction = TestCase $ do

2829

2930testErrorDBCFunction :: Test

3031testErrorDBCFunction = TestCase $ do

32+ (sess, conn) <- dateExamplesConnection emptyNotificationCallback

33+ let addfunc = "adddatabasecontextfunction \"retErr\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] ctx -> Left (DatabaseContextFunctionUserError \"err\")) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""

34+ executeTutorialD sess conn addfunc

35+ expectTutorialDErr sess conn (T.isPrefixOf "DatabaseContextFunctionUserError (DatabaseContextFunctionUserError \"err\")") "execute retErr()"

36+

37+testExceptionDBCFunction :: Test

38+testExceptionDBCFunction = TestCase $ do

3139 -- throw an error, make sure it is caught- it might not be caught, for example, if the function is not forced

3240 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

33− let addfunc = "adddatabasecontextfunction \"bomb\" DatabaseContext -> DatabaseContext \"\"\"(\\[] _ -> error \"boom\") :: [Atom] -> DatabaseContext -> DatabaseContext\"\"\""

41+ let addfunc = "adddatabasecontextfunction \"bomb\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] _ -> error \"boom\") :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""

3442 executeTutorialD sess conn addfunc

3543 expectTutorialDErr sess conn (\err -> "UnhandledExceptionError" `T.isPrefixOf` err) "execute bomb()"

44+

3645

3746{-

38−adddatabasecontextfunction "multiArgFunc" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> execState (evalContextExpr (Assign "person" (MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", NakedAtomExpr name), ("age", NakedAtomExpr age)])]))) ctx)"""

47+adddatabasecontextfunction "multiArgFunc" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> execState (evalDatabaseContextExpr (Assign "person" (MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", NakedAtomExpr name), ("age", NakedAtomExpr age)])]))) ctx)"""

3948-}

4049testDBCFunctionWithAtomArguments :: Test

4150testDBCFunctionWithAtomArguments = TestCase $ do

4251 --test function with creation of a relvar with some arguments

4352 (sess, conn) <- dateExamplesConnection emptyNotificationCallback

44− let addfunc = "adddatabasecontextfunction \"multiArgFunc\" Int -> Text -> DatabaseContext -> DatabaseContext \"\"\"(\\(age:name:_) ctx -> execState (evalContextExpr (Assign \"person\" (MakeRelationFromExprs Nothing [TupleExpr (fromList [(\"name\", NakedAtomExpr name), (\"age\", NakedAtomExpr age)])]))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext\"\"\""

53+ let addfunc = "adddatabasecontextfunction \"multiArgFunc\" Int -> Text -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\(age:name:_) ctx -> pure $ execState (evalDatabaseContextExpr (Assign \"person\" (MakeRelationFromExprs Nothing [TupleExpr (fromList [(\"name\", NakedAtomExpr name), (\"age\", NakedAtomExpr age)])]))) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""

4554 executeTutorialD sess conn addfunc

4655 executeTutorialD sess conn "execute multiArgFunc(30,\"Steve\")"

4756 result <- executeRelationalExpr sess conn (RelationVariable "person" ())