8b5114d · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

wip morphing function signatures

8b5114dAgentM7 years ago

src/lib/ProjectM36/Base.hs+6

compare with master

unifiedsplit

@@ -379,6 +379,12 @@ type TransactionHeads = M.Map HeadName Transaction

379-- | The transaction graph is the global database's state which references every committed transaction.

380data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)

381

382+transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

383+transactionHeadsForGraph (TransactionGraph hs _) = hs

384+

385+transactionsForGraph :: TransactionGraph -> S.Set Transaction

386+transactionsForGraph (TransactionGraph _ ts) = ts

387+

382-- | Every transaction has context-specific information attached to it.

388-- | Every transaction has context-specific information attached to it.

383-- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch).

389-- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch).

384data TransactionInfo = TransactionInfo {

390data TransactionInfo = TransactionInfo {

src/lib/ProjectM36/RelationalExpression.hs+83−43

@@ -13,6 +13,7 @@ import ProjectM36.DataTypes.Primitive

13import ProjectM36.AtomFunction

14import ProjectM36.DatabaseContextFunction

15import ProjectM36.Arbitrary

16+import ProjectM36.Transaction

16import qualified ProjectM36.Attribute as A

17import qualified ProjectM36.Attribute as A

17import qualified Data.Map as M

18import qualified Data.Map as M

18import qualified Data.HashSet as HS

19import qualified Data.HashSet as HS

@@ -58,9 +59,11 @@ freshDatabaseState context = DatabaseStateElems {

59-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52

60-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52

60data RelationalExprStateElems = RelationalExprStateElems {

61data RelationalExprStateElems = RelationalExprStateElems {

61− elems_context :: DatabaseContext,

62+ elems_context :: DatabaseContext,

62 elems_graph :: TransactionGraph,

63 elems_graph :: TransactionGraph,

64+ elems_currentTransId :: TransactionId,

63− elems_extra :: Maybe (Either RelationTuple Attributes) }

65+ elems_extra :: Maybe (Either RelationTuple Attributes)

66+ }

65stateTuple :: RelationalExprStateElems -> RelationTuple

68stateTuple :: RelationalExprStateElems -> RelationTuple

66stateTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (elems_extra e))

69stateTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (elems_extra e))

@@ -75,12 +78,14 @@ data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext Re

76instance Show RelationalExprStateElems where show e@RelationalExprStateElems{} = "RelationalExprStateElems " ++ show (elems_extra e)

79instance Show RelationalExprStateElems where show e@RelationalExprStateElems{} = "RelationalExprStateElems " ++ show (elems_extra e)

78−mkRelationalExprState :: DatabaseContext -> TransactionGraph -> RelationalExprStateElems

81+mkRelationalExprState :: DatabaseContext -> TransactionId -> TransactionGraph -> RelationalExprStateElems

82+mkRelationalExprState ctx currentTransId graph =

79−mkRelationalExprState ctx graph = RelationalExprStateElems

83+ RelationalExprStateElems

80− { elems_context = ctx,

84+ { elems_context = ctx,

81− elems_graph = graph,

85+ elems_graph = graph,

86+ elems_currentTransId = currentTransId,

82− elems_extra = Nothing }

87+ elems_extra = Nothing }

83−

88+

84mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems

89mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems

85mergeTuplesIntoRelationalExprState tupIn e@RelationalExprStateElems{} =

90mergeTuplesIntoRelationalExprState tupIn e@RelationalExprStateElems{} =

86 e{elems_extra = new_elems }

91 e{elems_extra = new_elems }

@@ -327,16 +332,16 @@ evalDatabaseContextExpr (Undefine relVarName) _ _ = deleteRelVar relVarName

327evalDatabaseContextExpr (Assign relVarName expr) transId graph = do

332evalDatabaseContextExpr (Assign relVarName expr) transId graph = do

328 context <- getStateContext

333 context <- getStateContext

329 let existingRelVar = M.lookup relVarName (relationVariables context)

334 let existingRelVar = M.lookup relVarName (relationVariables context)

330− relExprState = mkRelationalExprState context graph

335+ relExprState = mkRelationalExprState context transId graph

331 case existingRelVar of

336 case existingRelVar of

332 Nothing -> do

337 Nothing -> do

333− let ervExpr = runReader (evalRelationalExpr expr) relExprState

338+ let ervExpr = runReader (evalRelationalExpr expr) relExprState

334 case ervExpr of

339 case ervExpr of

335 Left err -> pure (Left err)

340 Left err -> pure (Left err)

336 Right rvExpr -> setRelVar relVarName rvExpr transId graph

341 Right rvExpr -> setRelVar relVarName rvExpr transId graph

337 Just existingRel -> do

342 Just existingRel -> do

338 let eExpectedType = typeForGraphRefRelationalExpr existingRel graph

343 let eExpectedType = typeForGraphRefRelationalExpr existingRel graph

339− eNewExprType = runReader (typeForRelationalExpr expr transId graph) relExprState

344+ eNewExprType = runReader (typeForRelationalExpr expr) relExprState

340 case eExpectedType of

345 case eExpectedType of

341 Left err -> pure (Left err)

346 Left err -> pure (Left err)

342 Right expectedType ->

347 Right expectedType ->

@@ -358,7 +363,7 @@ evalDatabaseContextExpr (Insert relVarName relExpr) tid graph =

358evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do

363evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do

359 ctx <- getStateContext

364 ctx <- getStateContext

360 let rv = RelationVariable relVarName transId

365 let rv = RelationVariable relVarName transId

361− rvState = mkRelationalExprState ctx graph

366+ rvState = mkRelationalExprState ctx transId graph

362 case runReader (processRestrictionPredicateExpr predicate) rvState of

367 case runReader (processRestrictionPredicateExpr predicate) rvState of

363 Left err -> pure (Left err)

368 Left err -> pure (Left err)

364 Right graphRefPredicate ->

369 Right graphRefPredicate ->

@@ -367,7 +372,7 @@ evalDatabaseContextExpr (Delete relVarName predicate) transId graph = do

367--union of restricted+updated portion and the unrestricted+unupdated portion

372--union of restricted+updated portion and the unrestricted+unupdated portion

368evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId graph = do

373evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) transId graph = do

369 context <- getStateContext

374 context <- getStateContext

370− let rvState = mkRelationalExprState context graph

375+ let rvState = mkRelationalExprState context transId graph

371 relVarTable = relationVariables context

376 relVarTable = relationVariables context

372 case runReader (processRestrictionPredicateExpr restrictionPredicateExpr) rvState of

377 case runReader (processRestrictionPredicateExpr restrictionPredicateExpr) rvState of

373 Left err -> pure (Left err)

378 Left err -> pure (Left err)

@@ -496,10 +501,10 @@ evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) _ _ = do

496 else

501 else

497 pure (Left (PrecompiledFunctionRemoveError funcName))

502 pure (Left (PrecompiledFunctionRemoveError funcName))

498

503

499−evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) _ graph = do

504+evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) transId graph = do

500 context <- getStateContext

505 context <- getStateContext

501 --resolve atom arguments

506 --resolve atom arguments

502− let relExprState = mkRelationalExprState context graph

507+ let relExprState = mkRelationalExprState context transId graph

503 eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs

508 eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs

504 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

509 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

505 case eFunc of

510 case eFunc of

@@ -664,13 +669,13 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

664

669

665 deps = inclusionDependencies context

670 deps = inclusionDependencies context

666 eval expr = evalReader (evalRelationalExpr expr)

671 eval expr = evalReader (evalRelationalExpr expr)

667− evalReader f = runReader f (mkRelationalExprState context graph)

672+ evalReader f = runReader f (mkRelationalExprState context transId graph)

668 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

673 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

669− let gfSubsetExpr = processRelationalExpr subsetExpr transId

674+ let gfSubsetExpr = evalReader (processRelationalExpr subsetExpr)

670− gfSupersetExpr = processRelationalExpr supersetExpr transId

675+ gfSupersetExpr = evalReader (processRelationalExpr supersetExpr)

671 --if both expressions are of a single-attribute (such as with a simple foreign key), the names of the attributes are irrelevant (they need not match) because the expression is unambiguous, but special-casing this to rename the attribute automatically would not be orthogonal behavior and probably cause confusion. Instead, special case the error to make it clear.

676 --if both expressions are of a single-attribute (such as with a simple foreign key), the names of the attributes are irrelevant (they need not match) because the expression is unambiguous, but special-casing this to rename the attribute automatically would not be orthogonal behavior and probably cause confusion. Instead, special case the error to make it clear.

672− typeSub <- evalReader (typeForRelationalExpr subsetExpr transId graph)

677+ typeSub <- evalReader (typeForRelationalExpr subsetExpr)

673− typeSuper <- evalReader (typeForRelationalExpr supersetExpr transId graph)

678+ typeSuper <- evalReader (typeForRelationalExpr supersetExpr)

674 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))

679 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))

675 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

680 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

676 case evalGraphRefRelationalExpr checkExpr potentialGraph of

681 case evalGraphRefRelationalExpr checkExpr potentialGraph of

@@ -683,13 +688,12 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

683-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing

688-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing

684-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation

689-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation

685

690

686−typeForRelationalExpr :: RelationalExpr -> TransactionId -> TransactionGraph -> RelationalExprState (Either RelationalError Relation)

691+typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)

687−typeForRelationalExpr expr transId graph = do

692+typeForRelationalExpr expr = do

688− rstate <- ask

693+ graph <- elems_graph <$> ask

689− let context = stateElemsContext rstate

690 --replace the relationVariables context element with a cloned set of relation devoid of tuples

694 --replace the relationVariables context element with a cloned set of relation devoid of tuples

691 --evalRelationalExpr could still return an existing relation with tuples, so strip them

695 --evalRelationalExpr could still return an existing relation with tuples, so strip them

692− let gfExpr = processRelationalExpr expr transId

696+ gfExpr <- processRelationalExpr expr

693 pure (typeForGraphRefRelationalExpr gfExpr graph)

697 pure (typeForGraphRefRelationalExpr gfExpr graph)

694

698

695--returns a database context with all tuples removed

699--returns a database context with all tuples removed

@@ -809,8 +813,12 @@ extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomE

809 Left err -> Left err

813 Left err -> Left err

810 Right atom -> Right (tupleAtomExtend newAttrName atom tup)

814 Right atom -> Right (tupleAtomExtend newAttrName atom tup)

811 )

815 )

812−{-

816+

817+

813evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)

818evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)

819+evalAtomExpr = undefined

820+{-

821+

814evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of

822evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of

815 Right atom -> pure (Right atom)

823 Right atom -> pure (Right atom)

816 err@(Left (NoSuchAttributeNamesError _)) -> do

824 err@(Left (NoSuchAttributeNamesError _)) -> do

@@ -889,10 +897,12 @@ typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do

889 case eTvMap of

897 case eTvMap of

890 Left err -> pure (Left err)

898 Left err -> pure (Left err)

891 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)

899 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)

892−typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do

900+typeFromAtomExpr attrs (RelationAtomExpr relExpr) = do

893− rstate <- lift ask

894− relType <- either throwE pure (runReader (typeForRelationalExpr relExpr () (mergeAttributesIntoRelationalExprState attrs rstate))

901+ relType <- local (mergeAttributesIntoRelationalExprState attrs) (typeForRelationalExpr relExpr)

902+ case relType of

903+ Left err -> pure (Left err)

904+ Right relType' ->

895− pure (RelationAtomType (attributes relType))

905+ pure (pure (RelationAtomType (attributes relType')))

896-- grab the type of the data constructor, then validate that the args match the expected types

906-- grab the type of the data constructor, then validate that the args match the expected types

897typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =

907typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =

898 runExceptT $ do

908 runExceptT $ do

@@ -907,11 +917,11 @@ verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT

907 case A.atomTypeForAttributeName attrName (attributes relIn) of

917 case A.atomTypeForAttributeName attrName (attributes relIn) of

908 Right aType -> either throwE pure (atomTypeVerify expectedType aType)

918 Right aType -> either throwE pure (atomTypeVerify expectedType aType)

909 (Left err@(NoSuchAttributeNamesError _)) ->

919 (Left err@(NoSuchAttributeNamesError _)) ->

910− let attrs' = stateAttrs rstate in

920+ let attrs' = stateAttributes rstate in

911 if attrs' == emptyAttributes then

921 if attrs' == emptyAttributes then

912 throwE err

922 throwE err

913 else

923 else

914− case A.attributeForName attrName attrs of

924+ case A.attributeForName attrName attrs' of

915 Left err' -> throwE err'

925 Left err' -> throwE err'

916 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))

926 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))

917verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))

927verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))

@@ -1035,7 +1045,7 @@ evalGraphRefRelationalExpr (RelationVariable name tid) graph = do

1035dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext

1045dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext

1036dbContextForTransId tid graph = do

1046dbContextForTransId tid graph = do

1037 trans <- transactionForId tid graph

1047 trans <- transactionForId tid graph

1038− pure (concreteDatabaseContext ctx)

1048+ pure (concreteDatabaseContext trans)

1039

1049

1040transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction

1050transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction

1041transactionForId tid graph

1051transactionForId tid graph

@@ -1049,14 +1059,44 @@ transactionForId tid graph

1049 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)

1059 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)

1050

1060

1051processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState (Either RelationalError GraphRefRestrictionPredicateExpr)

1061processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState (Either RelationalError GraphRefRestrictionPredicateExpr)

1052−processRestrictionPredicateExpr TruePredicate = TruePredicate

1062+processRestrictionPredicateExpr TruePredicate = pure (Right TruePredicate)

1053−processRestrictionPredicateExpr (AndPredicate a b) = pure $ AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b

1063+processRestrictionPredicateExpr (AndPredicate a b) = do

1064+ a' <- processRestrictionPredicateExpr a

1065+ b' <- processRestrictionPredicateExpr b

1066+ case a' of

1067+ Left err -> pure (Left err)

1068+ Right a'' -> case b' of

1069+ Left err -> pure (Left err)

1070+ Right b'' ->

1071+ pure (Right (AndPredicate a'' b''))

1054−processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b

1072+processRestrictionPredicateExpr (OrPredicate a b) = do

1073+ a' <- processRestrictionPredicateExpr a

1074+ b' <- processRestrictionPredicateExpr b

1075+ case a' of

1076+ Left err -> pure (Left err)

1077+ Right a'' -> case b' of

1078+ Left err -> pure (Left err)

1079+ Right b'' ->

1080+ pure (Right (OrPredicate a'' b''))

1055−processRestrictionPredicateExpr (NotPredicate a) = pure $ NotPredicate <$> processRestrictionPredicateExpr a

1081+processRestrictionPredicateExpr (NotPredicate a) = do

1082+ a' <- processRestrictionPredicateExpr a

1083+ case a' of

1084+ Left err -> pure (Left err)

1085+ Right a'' ->

1086+ pure (Right (NotPredicate a''))

1056−processRestrictionPredicateExpr (RelationalExprPredicate expr) = pure $ RelationalExprPredicate <$> evalRelationalExpr expr

1087+processRestrictionPredicateExpr (RelationalExprPredicate expr) = do

1088+ e <- evalRelationalExpr expr

1089+ pure $ case e of

1090+ Left err -> Left err

1091+ Right e' -> Right (RelationalExprPredicate e')

1057−processRestrictionPredicateExpr (AtomExprPredicate expr) = AtomExprPredicate <$> evalAtomExpr expr

1092+processRestrictionPredicateExpr (AtomExprPredicate expr) = do

1093+ tid <- elems_currentTransId <$> ask

1094+ let e = processAtomExpr expr tid

1095+ pure (Right (AtomExprPredicate e))

1058−processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = AttributeEqualityPredicate nam <$> evalAtomExpr expr

1096+processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) = do

1059−

1097+ tid <- elems_currentTransId <$> ask

1098+ let e = processAtomExpr expr tid

1099+ pure (Right (AttributeEqualityPredicate nam e))

1060processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError (ExtendTupleExprBase a))

1100processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState (Either RelationalError (ExtendTupleExprBase a))

1061processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do

1101processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) = do

1062 eExpr <- evalAtomExpr atomExpr

1102 eExpr <- evalAtomExpr atomExpr

@@ -1155,6 +1195,6 @@ processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) tid = AttributeAndT

1155processAttributeExpr (NakedAttributeExpr attr) = NakedAttributeExpr attr

1195processAttributeExpr (NakedAttributeExpr attr) = NakedAttributeExpr attr

1156

1196

1157-- convert a RelationalExpr into a GraphRefRelationalExpr

1197-- convert a RelationalExpr into a GraphRefRelationalExpr

1158−processRelationalExpr :: RelationalExpr -> TransactionId -> GraphRefRelationalExpr

1198+processRelationalExpr :: RelationalExpr -> RelationalExprState GraphRefRelationalExpr

1159−processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) =

1199+processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do

1160 MakeRelationFromExprs (fmap (fmap processAttributeExpr) mAttrs) (processTupleExprs tupleExprs)

1200 MakeRelationFromExprs (fmap (fmap processAttributeExpr) mAttrs) (processTupleExprs tupleExprs)

src/lib/ProjectM36/TransactionGraph.hs−6

@@ -88,12 +88,6 @@ headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchi

88 where

89 matchingTrans = M.filter (transaction ==) heads

91−transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

92−transactionHeadsForGraph (TransactionGraph hs _) = hs

93−

94−transactionsForGraph :: TransactionGraph -> S.Set Transaction

95−transactionsForGraph (TransactionGraph _ ts) = ts

96−

97transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)

91transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)

98transactionsForIds idSet graph =

92transactionsForIds idSet graph =

99 S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)

93 S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)