1706097 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP partial compilation checkpoint

1706097AgentM7 years ago

src/lib/ProjectM36/Atom.hs+3−1

compare with master

unifiedsplit

@@ -3,7 +3,9 @@ import ProjectM36.Base

3import ProjectM36.Error

4import ProjectM36.DataTypes.Interval

5import qualified Data.Text as T

6+#if __GLASGOW_HASKELL__ <= 802

6−--import Data.Monoid

7+import Data.Monoid

8+#endif

8relationForAtom :: Atom -> Either RelationalError Relation

10relationForAtom :: Atom -> Either RelationalError Relation

9relationForAtom (RelationAtom rel) = Right rel

11relationForAtom (RelationAtom rel) = Right rel

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

@@ -817,7 +817,10 @@ executeSchemaExpr sessionId (InProcessConnection conf) schemaExpr = atomically $

817 Left err -> pure (Left err)

818 Right (session, _) -> do

819 let subschemas' = subschemas session

820+ transId = Sess.parentId session

821+ context = Sess.concreteDatabaseContext session

822+ graph <- readTVar (ipTransactionGraph conf)

820− case Schema.evalSchemaExpr schemaExpr (Sess.concreteDatabaseContext session) subschemas' of

823+ case Schema.evalSchemaExpr schemaExpr context transId graph subschemas' of

821 Left err -> pure (Left err)

824 Left err -> pure (Left err)

822 Right (newSubschemas, newContext) -> do

825 Right (newSubschemas, newContext) -> do

823 --hm- maybe we should start using lenses

826 --hm- maybe we should start using lenses

@@ -957,10 +960,11 @@ relationVariablesAsRelation sessionId (InProcessConnection conf) = do

957 Left err -> pure (Left err)

960 Left err -> pure (Left err)

958 Right (session, schema) -> do

961 Right (session, schema) -> do

959 let context = Sess.concreteDatabaseContext session

962 let context = Sess.concreteDatabaseContext session

963+ transId = Sess.parentId session

960 if Sess.schemaName session == defaultSchemaName then

964 if Sess.schemaName session == defaultSchemaName then

961 pure $ RE.relationVariablesAsRelation (relationVariables context) graph

965 pure $ RE.relationVariablesAsRelation (relationVariables context) graph

962 else

966 else

963− case Schema.relationVariablesInSchema schema context of

967+ case Schema.relationVariablesInSchema schema context transId graph of

964 Left err -> pure (Left err)

968 Left err -> pure (Left err)

965 Right relvars -> pure $ RE.relationVariablesAsRelation relvars graph

969 Right relvars -> pure $ RE.relationVariablesAsRelation relvars graph

966

970

src/lib/ProjectM36/DataFrame.hs+3−1

@@ -18,7 +18,9 @@ import Data.Maybe

18import qualified Data.Text as T

19import Data.Binary

20import Control.Arrow

21+#if __GLASGOW_HASKELL__ <= 802

21−--import Data.Monoid

22+import Data.Monoid

23+#endif

23data AttributeOrderExpr = AttributeOrderExpr AttributeName Order deriving (Show, Generic, Binary)

25data AttributeOrderExpr = AttributeOrderExpr AttributeName Order deriving (Show, Generic, Binary)

24data AttributeOrder = AttributeOrder AttributeName Order deriving (Show, Generic, Binary)

26data AttributeOrder = AttributeOrder AttributeName Order deriving (Show, Generic, Binary)

src/lib/ProjectM36/IsomorphicSchema.hs+27−25

@@ -3,18 +3,21 @@ module ProjectM36.IsomorphicSchema where

3import ProjectM36.Base

4import ProjectM36.Error

5import ProjectM36.MiscUtils

6−import ProjectM36.RelationalExpression

7import ProjectM36.Relation

6import ProjectM36.Relation

7+import ProjectM36.NormalizeExpr

8+import ProjectM36.RelationalExpression

8import qualified ProjectM36.AttributeNames as AN

9import qualified ProjectM36.AttributeNames as AN

9import Control.Monad

10import Control.Monad

10−import Control.Monad.State

11−import Control.Monad.Trans.Reader

12import GHC.Generics

11import GHC.Generics

13import Data.Binary

12import Data.Binary

14import qualified Data.Map as M

13import qualified Data.Map as M

15import qualified Data.Set as S

14import qualified Data.Set as S

16import qualified Data.List as L

15import qualified Data.List as L

16+import Control.Monad.Reader

17+#if __GLASGOW_HASKELL__ <= 802

17−--import Data.Monoid

18+import Data.Monoid

19+#endif

20+

18-- isomorphic schemas offer bi-directional functors between two schemas

21-- isomorphic schemas offer bi-directional functors between two schemas

20--TODO: note that renaming a relvar should alter any stored isomorphisms as well

23--TODO: note that renaming a relvar should alter any stored isomorphisms as well

@@ -254,15 +257,15 @@ inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do

254inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies

257inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies

255inclusionDependenciesInSchema schema incDeps = M.fromList <$> mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps)

258inclusionDependenciesInSchema schema incDeps = M.fromList <$> mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps)

256

259

257−relationVariablesInSchema :: Schema -> DatabaseContext -> Either RelationalError RelationVariables

260+relationVariablesInSchema :: Schema -> DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError RelationVariables

258−relationVariablesInSchema schema@(Schema morphs) context = foldM transform M.empty morphs

261+relationVariablesInSchema schema@(Schema morphs) context transId graph = foldM transform M.empty morphs

259 where

262 where

260 transform newRvMap morph = do

263 transform newRvMap morph = do

261 let rvNames = isomorphInRelVarNames morph

264 let rvNames = isomorphInRelVarNames morph

262 rvAssocs <- mapM (\rv -> do

265 rvAssocs <- mapM (\rv -> do

263 expr' <- processRelationalExprInSchema schema (RelationVariable rv ())

266 expr' <- processRelationalExprInSchema schema (RelationVariable rv ())

264− rel <- unimplemented --runReader (evalRelationalExpr expr') (RelationalExprStateElems context)

267+ let gfExpr = runProcessExprM transId graph (processRelationalExpr expr')

265− pure (rv, rel)) rvNames

268+ pure (rv, gfExpr)) rvNames

266 pure (M.union newRvMap (M.fromList rvAssocs))

269 pure (M.union newRvMap (M.fromList rvAssocs))

267

270

268

271

@@ -310,25 +313,24 @@ createIncDepsForIsomorph sname (IsoRestrict origRv predi (rvTrue, rvFalse)) = le

310createIncDepsForIsomorph _ _ = M.empty

313createIncDepsForIsomorph _ _ = M.empty

311

314

312-- in the case of IsoRestrict, the database context should be updated with the restriction so that if the restriction does not hold, then the schema cannot be created

315-- in the case of IsoRestrict, the database context should be updated with the restriction so that if the restriction does not hold, then the schema cannot be created

313−evalSchemaExpr :: SchemaExpr -> DatabaseContext -> Subschemas -> Either RelationalError (Subschemas, DatabaseContext)

316+evalSchemaExpr :: SchemaExpr -> DatabaseContext -> TransactionId -> TransactionGraph -> Subschemas -> Either RelationalError (Subschemas, DatabaseContext)

314−evalSchemaExpr (AddSubschema sname morphs) context sschemas =

317+evalSchemaExpr (AddSubschema sname morphs) context transId graph sschemas =

315 if M.member sname sschemas then

318 if M.member sname sschemas then

316 Left (SubschemaNameInUseError sname)

319 Left (SubschemaNameInUseError sname)

317− else case valid of

320+ else

321+ case validateSchema (Schema morphs) context of

318− Just err -> Left (SchemaCreationError err)

322+ Just err -> Left (SchemaCreationError err)

319− Nothing ->

323+ Nothing -> do

320− let newSchemas = M.insert sname newSchema sschemas

324+ let newSchemas = M.insert sname newSchema sschemas

325+ newSchema = Schema morphs

321− moreIncDeps = foldr (\morph acc -> M.union acc (createIncDepsForIsomorph sname morph)) M.empty morphs

326+ moreIncDeps = foldr (\morph acc -> M.union acc (createIncDepsForIsomorph sname morph)) M.empty morphs

322− incDepExprs = MultipleExpr (map (uncurry AddInclusionDependency) (M.toList moreIncDeps))

327+ incDepExprs = MultipleExpr (map (uncurry AddInclusionDependency) (M.toList moreIncDeps))

323− in

328+ dbenv = mkDatabaseContextEvalEnv transId graph

324− case unimplemented of

329+ dbstate <- runDatabaseContextEvalMonad context dbenv (evalGraphRefDatabaseContextExpr incDepExprs)

325−-- case runState (evalDatabaseContextExpr incDepExprs) (context, M.empty, False) of

330+ pure (newSchemas, dbc_context dbstate)

326− (Left err, _) -> Left err

327− (Right (), (newContext,_,_)) -> pure (newSchemas, newContext) --need to propagate dirty flag here

331+--need to propagate dirty flag here

328− where

332+

329− newSchema = Schema morphs

330− valid = validateSchema newSchema context

331−evalSchemaExpr (RemoveSubschema sname) context sschemas = if M.member sname sschemas then

333+evalSchemaExpr (RemoveSubschema sname) context _ _ sschemas = if M.member sname sschemas then

332 pure (M.delete sname sschemas, context)

334 pure (M.delete sname sschemas, context)

333 else

335 else

334 Left (SubschemaNameNotInUseError sname)

336 Left (SubschemaNameNotInUseError sname)

src/lib/ProjectM36/Key.hs+3−1

@@ -2,7 +2,9 @@ module ProjectM36.Key where

2import ProjectM36.Base

3import ProjectM36.Relation

4import qualified Data.Set as S

5+#if __GLASGOW_HASKELL__ <= 802

5−--import Data.Monoid

6+import Data.Monoid

7+#endif

7{-

9{-

8keys can be implemented using inclusion dependencies as well: the count of the projection of the keys' attributes must be equal to the count of the tuples- p. 120 Database in Depth

10keys can be implemented using inclusion dependencies as well: the count of the projection of the keys' attributes must be equal to the count of the tuples- p. 120 Database in Depth

src/lib/ProjectM36/NormalizeExpr.hsnew file+124

@@ -0,0 +1,124 @@

1+-- | Functions to convert all types of expresions into their GraphRef- equivalents.

2+module ProjectM36.NormalizeExpr where

3+import ProjectM36.Base

4+import Control.Monad.Trans.Reader as R

5+import qualified Data.Map as M

7+--used to process/normalize exprs to their respective graph ref forms

8+type ProcessExprM a = Reader (TransactionGraph, TransactionId) a

10+type CurrentTransactionId = TransactionId

11+

12+runProcessExprM :: CurrentTransactionId -> TransactionGraph -> ProcessExprM a -> a

13+runProcessExprM tid graph m = runReader m (graph, tid)

14+

15+askGraph :: ProcessExprM TransactionGraph

16+askGraph = fst <$> R.ask

17+

18+askTid :: ProcessExprM CurrentTransactionId

19+askTid = snd <$> R.ask

20+

21+-- convert a RelationalExpr into a GraphRefRelationalExpr using the current trans Id

22+processRelationalExpr :: RelationalExpr -> ProcessExprM GraphRefRelationalExpr

23+processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do

24+ mAttrs' <- case mAttrs of

25+ Nothing -> pure Nothing

26+ Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''

27+ MakeRelationFromExprs mAttrs' <$> mapM processTupleExpr tupleExprs

28+processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)

29+processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)

30+--requires current trans id and graph

31+processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> askTid

32+processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr

33+processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB

34+processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB

35+processRelationalExpr (Rename attrA attrB expr) =

36+ Rename attrA attrB <$> processRelationalExpr expr

37+processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB

38+processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr

39+processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr

40+processRelationalExpr (Restrict pred expr) = Restrict <$> processRestrictionPredicateExpr pred <*> processRelationalExpr expr

41+processRelationalExpr (Equals exprA exprB) =

42+ Equals <$> processRelationalExpr exprA <*> processRelationalExpr exprB

43+processRelationalExpr (NotEquals exprA exprB) =

44+ NotEquals <$> processRelationalExpr exprA <*> processRelationalExpr exprB

45+processRelationalExpr (Extend extendExpr expr) =

46+ Extend <$> processExtendTupleExpr extendExpr <*> processRelationalExpr expr

47+processRelationalExpr (With macros expr) =

48+ With <$> mapM (\(nam, wexpr) -> (,) nam <$> processRelationalExpr wexpr) macros <*> processRelationalExpr expr

49+

50+processAttributeNames :: AttributeNames -> ProcessExprM GraphRefAttributeNames

51+processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet

52+processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB

53+processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB

54+processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr

55+

56+processDatabaseContextExpr :: DatabaseContextExpr -> ProcessExprM GraphRefDatabaseContextExpr

57+processDatabaseContextExpr expr =

58+ case expr of

59+ NoOperation -> pure NoOperation

60+ Define nam attrExprs -> Define nam <$> mapM processAttributeExpr attrExprs

61+ Undefine nam -> pure (Undefine nam)

62+ Assign nam rexpr -> Assign nam <$> processRelationalExpr rexpr

63+ Insert nam rexpr -> Insert nam <$> processRelationalExpr rexpr

64+ Delete nam pred -> Delete nam <$> processRestrictionPredicateExpr pred

65+ Update nam attrMap pred -> Update nam attrMap <$> processRestrictionPredicateExpr pred

66+

67+ AddInclusionDependency nam dep -> pure (AddInclusionDependency nam dep)

68+ RemoveInclusionDependency nam -> pure (RemoveInclusionDependency nam)

69+ AddNotification nam exprA exprB exprC -> pure (AddNotification nam exprA exprB exprC)

70+ RemoveNotification nam -> pure (RemoveNotification nam)

71+ AddTypeConstructor tyDef consDefs -> pure (AddTypeConstructor tyDef consDefs)

72+ RemoveTypeConstructor tyName -> pure (RemoveTypeConstructor tyName)

73+

74+ RemoveAtomFunction aFuncName -> pure (RemoveAtomFunction aFuncName)

75+ RemoveDatabaseContextFunction funcName -> pure (RemoveDatabaseContextFunction funcName)

76+ ExecuteDatabaseContextFunction funcName atomExprs -> ExecuteDatabaseContextFunction funcName <$> mapM processAtomExpr atomExprs

77+ MultipleExpr exprs -> MultipleExpr <$> mapM processDatabaseContextExpr exprs

78+

79+processDatabaseContextIOExpr :: DatabaseContextIOExpr -> ProcessExprM GraphRefDatabaseContextIOExpr

80+processDatabaseContextIOExpr (AddAtomFunction f tcs sc) =

81+ pure (AddAtomFunction f tcs sc)

82+processDatabaseContextIOExpr (LoadAtomFunctions mod fun file) =

83+ pure (LoadAtomFunctions mod fun file)

84+processDatabaseContextIOExpr (AddDatabaseContextFunction mod fun path) =

85+ pure (AddDatabaseContextFunction mod fun path)

86+processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod fun path) =

87+ pure (LoadDatabaseContextFunctions mod fun path)

88+processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =

89+ CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range

90+

91+processRestrictionPredicateExpr :: RestrictionPredicateExpr -> ProcessExprM GraphRefRestrictionPredicateExpr

92+processRestrictionPredicateExpr TruePredicate = pure TruePredicate

93+processRestrictionPredicateExpr (AndPredicate a b) = AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b

94+processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b

95+processRestrictionPredicateExpr (NotPredicate a) = NotPredicate <$> processRestrictionPredicateExpr a

96+processRestrictionPredicateExpr (RelationalExprPredicate expr) =

97+ RelationalExprPredicate <$> processRelationalExpr expr

98+processRestrictionPredicateExpr (AtomExprPredicate expr) =

99+ AtomExprPredicate <$> processAtomExpr expr

100+processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) =

101+ AttributeEqualityPredicate nam <$> processAtomExpr expr

102+

103+processExtendTupleExpr :: ExtendTupleExpr -> ProcessExprM GraphRefExtendTupleExpr

104+processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =

105+ AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr

106+

107+processAtomExpr :: AtomExpr -> ProcessExprM GraphRefAtomExpr

108+processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam

109+processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom

110+processAtomExpr (FunctionAtomExpr fName atomExprs ()) =

111+ FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> askTid

112+processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr

113+processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> askTid

114+

115+processTupleExpr :: TupleExpr -> ProcessExprM GraphRefTupleExpr

116+processTupleExpr (TupleExpr tMap) =

117+ TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)

118+

119+--convert AttributeExpr to GraphRefAttributeExpr

120+processAttributeExpr :: AttributeExpr -> ProcessExprM GraphRefAttributeExpr

121+processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) =

122+ AttributeAndTypeNameExpr nam tCons <$> askTid

123+processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr

124+

src/lib/ProjectM36/Relation/Show/HTML.hs+3−1

@@ -8,8 +8,10 @@ import qualified Data.List as L

8import Data.Text (Text, pack)

9import qualified Data.Text as T

10import qualified Data.Text.IO as TIO

11−--import Data.Monoid

12import qualified Data.Vector as V

11import qualified Data.Vector as V

12+#if __GLASGOW_HASKELL__ <= 802

13+import Data.Monoid

14+#endif

14attributesAsHTML :: Attributes -> Text

16attributesAsHTML :: Attributes -> Text

15attributesAsHTML attrs = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"

17attributesAsHTML attrs = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"

src/lib/ProjectM36/Relation/Show/Term.hs+3−1

@@ -9,7 +9,9 @@ import ProjectM36.Attribute hiding (null)

9import qualified Data.List as L

10import qualified Data.Text as T

11import Control.Arrow hiding (left)

12+#if __GLASGOW_HASKELL__ <= 802

12−--import Data.Monoid

13+import Data.Monoid

14+#endif

13import ProjectM36.WCWidth --guess the width that the character will appear as in the terminal

15import ProjectM36.WCWidth --guess the width that the character will appear as in the terminal

15boxV :: StringType

17boxV :: StringType

src/lib/ProjectM36/RelationalExpression.hs+297−402

@@ -18,7 +18,7 @@ import qualified ProjectM36.Attribute as A

18import qualified Data.Map as M

19import qualified Data.HashSet as HS

20import qualified Data.Set as S

21−import Control.Monad.Trans.RWS.Strict as RWS

21+import Control.Monad.RWS.Strict as RWS

22import Control.Monad.Trans.Class (lift)

23import Control.Exception

24import Data.Maybe

@@ -27,8 +27,10 @@ import Data.Char (isUpper)

27import qualified Data.Text as T

28import qualified Data.Vector as V

29import qualified ProjectM36.TypeConstructorDef as TCD

30−import Control.Monad.Trans.Except

30+import Control.Monad.Except

31+import Control.Monad.Trans.Except (except)

31−import Control.Monad.Trans.Reader as R

32+import Control.Monad.Reader as R

33+import ProjectM36.NormalizeExpr

32import Test.QuickCheck

34import Test.QuickCheck

33import GHC

35import GHC

34import GHC.Paths

36import GHC.Paths

@@ -38,6 +40,9 @@ import qualified Data.List.NonEmpty as NE

38import Data.Functor.Identity

40import Data.Functor.Identity

39import Control.Monad

41import Control.Monad

40import Control.Monad.IO.Class

42import Control.Monad.IO.Class

43+#if __GLASGOW_HASKELL__ <= 802

44+import Data.Monoid

45+#endif

42data DatabaseContextExprDetails = CountUpdatedTuples

47data DatabaseContextExprDetails = CountUpdatedTuples

@@ -69,15 +74,35 @@ data RelationalExprEnv = RelationalExprEnv {

69 re_extra :: Maybe (Either RelationTuple Attributes)

74 re_extra :: Maybe (Either RelationTuple Attributes)

70 }

75 }

72−stateTuple :: RelationalExprEnv -> RelationTuple

77+envTuple :: GraphRefRelationalExprEnv -> RelationTuple

73−stateTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (re_extra e))

78+envTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (gre_extra e))

75−stateAttributes :: RelationalExprEnv -> Attributes

80+envAttributes :: GraphRefRelationalExprEnv -> Attributes

76−stateAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (re_extra e))

81+envAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (gre_extra e))

78instance Show RelationalExprEnv where

83instance Show RelationalExprEnv where

79 show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)

84 show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)

86+--used to eval relationalexpr

87+type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a

88+

89+reGraph :: RelationalExprM TransactionGraph

90+reGraph = re_graph <$> R.ask

91+

92+gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction

93+gfTransForId tid = do

94+ graph <- gfGraph

95+ lift $ except $ transactionForId tid graph

96+

97+currentTrans :: RelationalExprM Transaction

98+currentTrans = do

99+ tid <- re_currentTransId <$> R.ask

100+ graph <- re_graph <$> R.ask

101+ lift $ except $ transactionForId tid graph

102+

103+reTransId :: RelationalExprM TransactionId

104+reTransId = re_currentTransId <$> R.ask

105+

81mkRelationalExprEnv :: DatabaseContext -> TransactionId -> TransactionGraph -> RelationalExprEnv

106mkRelationalExprEnv :: DatabaseContext -> TransactionId -> TransactionGraph -> RelationalExprEnv

82mkRelationalExprEnv ctx currentTransId graph =

107mkRelationalExprEnv ctx currentTransId graph =

83 RelationalExprEnv

108 RelationalExprEnv

@@ -86,27 +111,21 @@ mkRelationalExprEnv ctx currentTransId graph =

86 re_currentTransId = currentTransId,

111 re_currentTransId = currentTransId,

87 re_extra = Nothing }

112 re_extra = Nothing }

113

89−askEnv :: RelationalExprState RelationalExprEnv

114+askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv

90askEnv = R.ask

115askEnv = R.ask

116

92−currentTrans :: RelationalExprState (Either RelationalError Transaction)

117+mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv

93−currentTrans = do

118+mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =

94− tid <- re_currentTransId <$> R.ask

95− graph <- re_graph <$> R.ask

96− pure (transactionForId tid graph)

97−

98−mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprEnv -> RelationalExprEnv

99−mergeTuplesIntoRelationalExprState tupIn e@RelationalExprEnv{} =

100− e{re_extra = new_elems }

119+ e{ gre_extra = new_elems }

101 where

120 where

102 new_elems = Just (Left newTuple)

121 new_elems = Just (Left newTuple)

103− mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (stateTuple e))

122+ mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))

104 newTuple = mkRelationTupleFromMap mergedTupMap

123 newTuple = mkRelationTupleFromMap mergedTupMap

105

124

106−mergeAttributesIntoRelationalExprState :: Attributes -> RelationalExprEnv -> RelationalExprEnv

125+mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv

107−mergeAttributesIntoRelationalExprState attrsIn e@RelationalExprEnv{} = e{re_extra = newattrs }

126+mergeAttributesIntoGraphRefRelationalExprEnv attrsIn e = e { gre_extra = newattrs }

108 where

127 where

109− newattrs = Just (Right (A.union attrsIn (stateAttributes e)))

128+ newattrs = Just (Right (A.union attrsIn (envAttributes e)))

110

129

111type ResultAccumName = StringType

130type ResultAccumName = StringType

112

131

@@ -156,9 +175,25 @@ putStateContext ctx' = do

156 s <- get

175 s <- get

157 put (s {dbc_context = ctx'})

176 put (s {dbc_context = ctx'})

158

177

159−type RelationalExprState a = Reader RelationalExprEnv a

178+data GraphRefRelationalExprEnv =

179+ GraphRefRelationalExprEnv {

180+ gre_graph :: TransactionGraph,

181+ gre_extra :: Maybe (Either RelationTuple Attributes)

182+ }

183+

184+type GraphRefRelationalExprM a = ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity) a

185+

186+runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a

187+runGraphRefRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))

188+

189+freshGraphRefRelationalExprEnv :: TransactionGraph -> GraphRefRelationalExprEnv

190+freshGraphRefRelationalExprEnv graph = GraphRefRelationalExprEnv {

191+ gre_graph = graph,

192+ gre_extra = Nothing

193+ }

160

194

161−type GraphRefRelationalExprR a = Reader TransactionGraph a

195+gfGraph :: GraphRefRelationalExprM TransactionGraph

196+gfGraph = gre_graph <$> R.ask

162

197

163envContext :: RelationalExprEnv -> DatabaseContext

198envContext :: RelationalExprEnv -> DatabaseContext

164envContext = re_context

199envContext = re_context

@@ -354,12 +389,12 @@ evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do

354 relvars <- fmap relationVariables getStateContext

389 relvars <- fmap relationVariables getStateContext

355 tConss <- fmap typeConstructorMapping getStateContext

390 tConss <- fmap typeConstructorMapping getStateContext

356 relEnv <- dbcRelationalExprEnv

391 relEnv <- dbcRelationalExprEnv

392+ graph <- dbcGraph

357− let eAttrs = runReader (mapM evalGraphRefAttrExpr attrExprs) relEnv

393+ let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)

358− attrErrs = lefts eAttrs

394+ gfEnv = freshGraphRefRelationalExprEnv graph

359− attrsList = rights eAttrs

395+ case eAttrs of

360− if not (null attrErrs) then

396+ Left err -> dbErr err

361− dbErr (someErrors attrErrs)

397+ Right attrsList -> do

362− else do

363 let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList

398 let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList

364 if not (null atomTypeErrs) then

399 if not (null atomTypeErrs) then

365 dbErr (someErrors atomTypeErrs)

400 dbErr (someErrors atomTypeErrs)

@@ -381,8 +416,9 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

381 Nothing -> do

416 Nothing -> do

382 setRelVar relVarName expr

417 setRelVar relVarName expr

383 Just existingRel -> do

418 Just existingRel -> do

384− let eExpectedType = runReader (typeForGraphRefRelationalExpr existingRel) graph

419+ let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)

385− eNewExprType = runReader (typeForGraphRefRelationalExpr expr) graph

420+ eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)

421+ reEnv = freshGraphRefRelationalExprEnv graph

386 case eExpectedType of

422 case eExpectedType of

387 Left err -> dbErr err

423 Left err -> dbErr err

388 Right expectedType ->

424 Right expectedType ->

@@ -410,7 +446,7 @@ evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

410evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

446evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

411 context <- getStateContext

447 context <- getStateContext

412 transId <- dbcTransId

448 transId <- dbcTransId

413− reEnv <- dbcRelationalExprEnv

449+ graph <- dbcGraph

414 let relVarMap = relationVariables context

450 let relVarMap = relationVariables context

415 case M.lookup relVarName relVarMap of

451 case M.lookup relVarName relVarMap of

416 Nothing -> dbErr (RelVarNotDefinedError relVarName)

452 Nothing -> dbErr (RelVarNotDefinedError relVarName)

@@ -422,7 +458,7 @@ evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

422 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

458 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

423 restrictedPortion = Restrict pred'

459 restrictedPortion = Restrict pred'

424 updated = foldr (\(oldname, atomExpr) accum ->

460 updated = foldr (\(oldname, atomExpr) accum ->

425− let procAtomExpr = runReader (processAtomExpr atomExpr) reEnv in

461+ let procAtomExpr = runProcessExprM transId graph (processAtomExpr atomExpr) in

426 updateAttr oldname procAtomExpr accum

462 updateAttr oldname procAtomExpr accum

427 ) rv (M.toList atomExprMap)

463 ) rv (M.toList atomExprMap)

428 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds

464 -- the atomExprMap could reference other attributes, so we must perform multi-pass folds

@@ -537,9 +573,11 @@ evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do

537evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

573evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do

538 context <- getStateContext

574 context <- getStateContext

539 relExprEnv <- dbcRelationalExprEnv

575 relExprEnv <- dbcRelationalExprEnv

576+ graph <- dbcGraph

540 --resolve atom arguments

577 --resolve atom arguments

541− let eAtomTypes = map (\atomExpr -> runReader (typeForGraphRefAtomExpr emptyAttributes atomExpr) relExprEnv) atomArgExprs

578+ let eAtomTypes = mapM (\atomExpr -> runGraphRefRelationalExprM gfEnv (typeForGraphRefAtomExpr emptyAttributes atomExpr)) atomArgExprs

542 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

579 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)

580+ gfEnv = freshGraphRefRelationalExprEnv graph

543 case eFunc of

581 case eFunc of

544 Left err -> dbErr err

582 Left err -> dbErr err

545 Right func -> do

583 Right func -> do

@@ -549,10 +587,9 @@ evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArg

549 dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

587 dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

550 else

588 else

551 --check that the atom types are valid

589 --check that the atom types are valid

552− case lefts eAtomTypes of

590+ case eAtomTypes of

553− _:_ -> dbErr (someErrors (lefts eAtomTypes))

591+ Left err -> dbErr err

554− [] -> do

555− let atomTypes = rights eAtomTypes

592+ Right atomTypes -> do

556 let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of

593 let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of

557 Left err -> Just err

594 Left err -> Just err

558 Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)

595 Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)

@@ -711,36 +748,39 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

711 graph = dbcio_graph env

748 graph = dbcio_graph env

712 case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of

749 case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of

713 Left err -> pure (Left err)

750 Left err -> pure (Left err)

714− Right state -> do

751+ Right dbstate -> do

715 --Assign

752 --Assign

716 let existingRelVar = M.lookup relVarName relVarTable

753 let existingRelVar = M.lookup relVarName relVarTable

717− relVarTable = relationVariables (dbc_context state)

754+ relVarTable = relationVariables (dbc_context dbstate)

718 case existingRelVar of

755 case existingRelVar of

719 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

756 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)

720 Just existingRel -> do

757 Just existingRel -> do

758+ let env = freshGraphRefRelationalExprEnv graph

721− case runReader (typeForGraphRefRelationalExpr existingRel) graph of

759+ case runGraphRefRelationalExprM env (typeForGraphRefRelationalExpr existingRel) of

722 Left err -> pure (Left err)

760 Left err -> pure (Left err)

723 Right relType -> do

761 Right relType -> do

724 let expectedAttributes = attributes relType

762 let expectedAttributes = attributes relType

725− tcMap = typeConstructorMapping (dbc_context state)

763+ tcMap = typeConstructorMapping (dbc_context dbstate)

726 eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap

764 eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap

727 case eitherRel of

765 case eitherRel of

728 Left err -> pure $ Left err

766 Left err -> pure $ Left err

729 Right rel ->

767 Right rel ->

730 case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of

768 case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of

731 Left err -> pure (Left err)

769 Left err -> pure (Left err)

732− Right state -> putDBCIOContext (dbc_context state)

770+ Right dbstate' -> putDBCIOContext (dbc_context dbstate')

733

771

772+{-

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

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

735updateTupleWithAtomExprs exprMap context graph tupIn = do

774updateTupleWithAtomExprs exprMap context graph tupIn = do

736 --resolve all atom exprs

775 --resolve all atom exprs

776+ let

737 atomsAssoc <- mapM (\(attrName, atomExpr) -> do

777 atomsAssoc <- mapM (\(attrName, atomExpr) -> do

738 let atom = unimplemented

778 let atom = unimplemented

739 --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)

779 --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)

740 pure (attrName, atom)

780 pure (attrName, atom)

741 ) (M.toList exprMap)

781 ) (M.toList exprMap)

742 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)

782 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)

743−

783+-}

744--run verification on all constraints

784--run verification on all constraints

745checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()

785checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()

746checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

786checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

@@ -756,14 +796,19 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

756 reEnv = mkRelationalExprEnv context transId graph

796 reEnv = mkRelationalExprEnv context transId graph

757 -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment

797 -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment

758 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

798 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do

799+ let process = runProcessExprM transId graph

759− let gfSubsetExpr = runReader (processRelationalExpr subsetExpr) reEnv

800+ gfSubsetExpr = process (processRelationalExpr subsetExpr)

760− gfSupersetExpr = runReader (processRelationalExpr supersetExpr) reEnv

801+ gfSupersetExpr = process (processRelationalExpr supersetExpr)

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

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

762− typeSub <- runReader (typeForRelationalExpr subsetExpr) reEnv

803+ let gfEnv = freshGraphRefRelationalExprEnv graph

763− typeSuper <- runReader (typeForRelationalExpr supersetExpr) reEnv

804+ runGfRel = runGraphRefRelationalExprM gfEnv

805+ typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)

806+ typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)

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

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

765 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

808 let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)

766− case evalGraphRefRelationalExpr checkExpr potentialGraph of

809+ gfEvald = runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr checkExpr)

810+ gfEnv = freshGraphRefRelationalExprEnv potentialGraph

811+ case gfEvald of

767 Left err -> Left err

812 Left err -> Left err

768 Right resultRel -> if resultRel == relationTrue then

813 Right resultRel -> if resultRel == relationTrue then

769 pure ()

814 pure ()

@@ -773,13 +818,16 @@ checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =

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

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

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

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

775

820

776−typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)

821+typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation

777typeForRelationalExpr expr = do

822typeForRelationalExpr expr = do

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

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

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

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

825+ graph <- reGraph

826+ transId <- reTransId

780− gfExpr <- processRelationalExpr expr

827+ let gfExpr = runProcessExprM transId graph (processRelationalExpr expr)

781− graph <- re_graph <$> askEnv

828+ gfEnv = freshGraphRefRelationalExprEnv graph

782− pure $ runReader (typeForGraphRefRelationalExpr gfExpr) graph

829+ runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

830+ lift $ except $ runGf

783

831

784--returns a database context with all tuples removed

832--returns a database context with all tuples removed

785--this is useful for type checking and optimization

833--this is useful for type checking and optimization

@@ -794,67 +842,66 @@ liftE :: (Monad m) => m (Either a b) -> ExceptT a m b

794liftE v = do

842liftE v = do

795 y <- lift v

843 y <- lift v

796 case y of

844 case y of

797− Left err -> throwE err

845+ Left err -> throwError err

798 Right val -> pure val

846 Right val -> pure val

799

847

800{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}

848{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}

801−predicateRestrictionFilter :: Attributes -> RestrictionPredicateExprBase a -> RelationalExprState (Either RelationalError RestrictionFilter)

849+predicateRestrictionFilter :: Attributes -> GraphRefRestrictionPredicateExpr -> GraphRefRelationalExprM RestrictionFilter

802−predicateRestrictionFilter attrs (AndPredicate expr1 expr2) =

850+predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do

803− runExceptT $ do

804− expr1v <- liftE (predicateRestrictionFilter attrs expr1)

851+ expr1v <- predicateRestrictionFilter attrs expr1

805− expr2v <- liftE (predicateRestrictionFilter attrs expr2)

852+ expr2v <- predicateRestrictionFilter attrs expr2

806− pure (\x -> do

853+ pure (\x -> do

807− ev1 <- expr1v x

854+ ev1 <- expr1v x

808− ev2 <- expr2v x

855+ ev2 <- expr2v x

809− pure (ev1 && ev2))

856+ pure (ev1 && ev2))

810−

857+

811−predicateRestrictionFilter attrs (OrPredicate expr1 expr2) =

858+predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do

812− runExceptT $ do

813− expr1v <- liftE (predicateRestrictionFilter attrs expr1)

859+ expr1v <- predicateRestrictionFilter attrs expr1

814− expr2v <- liftE (predicateRestrictionFilter attrs expr2)

860+ expr2v <- predicateRestrictionFilter attrs expr2

815 pure (\x -> do

861 pure (\x -> do

816 ev1 <- expr1v x

862 ev1 <- expr1v x

817 ev2 <- expr2v x

863 ev2 <- expr2v x

818 pure (ev1 || ev2))

864 pure (ev1 || ev2))

819

865

820−predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))

866+predicateRestrictionFilter _ TruePredicate = pure (\_ -> pure True)

821

867

822−predicateRestrictionFilter attrs (NotPredicate expr) =

868+predicateRestrictionFilter attrs (NotPredicate expr) = do

823− runExceptT $ do

824− exprv <- liftE (predicateRestrictionFilter attrs expr)

869+ exprv <- predicateRestrictionFilter attrs expr

825− pure (fmap not . exprv)

870+ pure (fmap not . exprv)

826

871

827--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here

872--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here

828−{-

829predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

873predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

830− rstate <- ask

874+ renv <- askEnv

831− pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of

875+ let eval :: RelationTuple -> Either RelationalError Relation

876+ eval tup =

877+ let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in

878+ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)

879+ pure (\tup -> case eval tup of

832 Left err -> Left err

880 Left err -> Left err

833 Right rel -> if arity rel /= 0 then

881 Right rel -> if arity rel /= 0 then

834 Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")

882 Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")

835 else

883 else

836− pure (rel == relationTrue)))

884+ pure (rel == relationTrue))

837

885

838predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do

886predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do

839− rstate <- ask

887+ env <- askEnv

840− let attrs' = stateAttributes rstate

888+ let attrs' = envAttributes env

841− ctxtup' = stateTuple rstate

889+ ctxtup' = envTuple env

842− runExceptT $ do

843− atomExprType <- liftE (typeFromAtomExpr attrs' atomExpr)

890+ atomExprType <- typeForGraphRefAtomExpr attrs' atomExpr

844− attr <- either throwE pure $ case A.attributeForName attrName attrs of

891+ attr <- lift $ except $ case A.attributeForName attrName attrs of

845 Right attr -> Right attr

892 Right attr -> Right attr

846 Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of

893 Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of

847 Right ctxattr -> Right ctxattr

894 Right ctxattr -> Right ctxattr

848 Left err2@(NoSuchAttributeNamesError _) -> Left err2

895 Left err2@(NoSuchAttributeNamesError _) -> Left err2

849 Left err -> Left err

896 Left err -> Left err

850 Left err -> Left err

897 Left err -> Left err

851− if atomExprType /= A.atomType attr then

898+ if atomExprType /= A.atomType attr then

852− throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))

899+ throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))

853− else

900+ else

854 pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of

901 pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of

855 Right atomCmp -> atomCmp == atomIn

902 Right atomCmp -> atomCmp == atomIn

856 Left _ -> False

903 Left _ -> False

857− atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate

904+ atomEvald = runGraphRefRelationalExprM env (evalGraphRefAtomExpr tupleIn atomExpr)

858 in

905 in

859 pure $ case atomForAttributeName attrName tupleIn of

906 pure $ case atomForAttributeName attrName tupleIn of

860 Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of

907 Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of

@@ -865,43 +912,44 @@ predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr)

865-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance

912-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance

866predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do

913predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do

867 --merge attrs into the state attributes

914 --merge attrs into the state attributes

868− rstate <- ask

915+ renv <- askEnv

869− runExceptT $ do

870− aType <- liftE (typeFromAtomExpr attrs atomExpr)

916+ aType <- typeForGraphRefAtomExpr attrs atomExpr

871− if aType /= BoolAtomType then

917+ if aType /= BoolAtomType then

872− throwE (AtomTypeMismatchError aType BoolAtomType)

918+ throwError (AtomTypeMismatchError aType BoolAtomType)

873− else

919+ else

874 pure (\tupleIn ->

920 pure (\tupleIn ->

875− case runReader (evalAtomExpr tupleIn atomExpr) rstate of

921+ case runGraphRefRelationalExprM renv (evalGraphRefAtomExpr tupleIn atomExpr) of

876− Left err -> Left err

922+ Left err -> Left err

877− Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))

923+ Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))

878−-}

924+

879tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation

925tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation

880tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then

926tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then

881 Left (AttributeNameInUseError attrName)

927 Left (AttributeNameInUseError attrName)

882 else

928 else

883 Right rel

929 Right rel

884

930

885−extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))

931+extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)

886−extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do

932+extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do

887− rstate <- askEnv

933+ renv <- askEnv

888 -- check that the attribute name is not in use

934 -- check that the attribute name is not in use

889 case tupleExprCheckNewAttrName newAttrName relIn of

935 case tupleExprCheckNewAttrName newAttrName relIn of

890− Left err -> pure (Left err)

936+ Left err -> throwError err

891− Right _ -> runExceptT $ do

937+ Right _ -> do

892− atomExprType <- liftE (typeFromAtomExpr (attributes relIn) atomExpr)

938+ atomExprType <- typeForGraphRefAtomExpr (attributes relIn) atomExpr

893− atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)

939+ atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType

894 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']

940 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']

895 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

941 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs

896− pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in

942+ pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in

897 case unimplemented {-runReader (evalAtomExpr tup atomExpr) substate-} of

943 case unimplemented {-runReader (evalAtomExpr tup atomExpr) substate-} of

898 Left err -> Left err

944 Left err -> Left err

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

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

900 )

946 )

901

947

948+evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom

949+evalGraphRefAtomExpr = unimplemented

902

950

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

951+evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom

904−evalAtomExpr = undefined

952+evalAtomExpr = unimplemented

905{-

953{-

906

954

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

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

@@ -950,143 +998,129 @@ evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExcept

950 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs

998 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs

951 pure (ConstructedAtom dConsName aType argAtoms)

999 pure (ConstructedAtom dConsName aType argAtoms)

952-}

1000-}

953−typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> RelationalExprState (Either RelationalError AtomType)

1001+typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType

954typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do

1002typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do

955− rstate <- askEnv

1003+ renv <- askEnv

956 case A.atomTypeForAttributeName attrName attrs of

1004 case A.atomTypeForAttributeName attrName attrs of

957− Right aType -> pure (Right aType)

1005+ Right aType -> pure aType

958 Left err@(NoSuchAttributeNamesError _) ->

1006 Left err@(NoSuchAttributeNamesError _) ->

959− let stateTup = stateTuple rstate

1007+ let envTup = envTuple renv

960− stateAttrs = stateAttributes rstate in

1008+ envAttrs = envAttributes renv in

961− case A.attributeForName attrName stateAttrs of

1009+ case A.attributeForName attrName envAttrs of

962− Right attr -> pure (Right (A.atomType attr))

1010+ Right attr -> pure (A.atomType attr)

963− Left _ -> case atomForAttributeName attrName stateTup of

1011+ Left _ -> case atomForAttributeName attrName envTup of

964− Right atom -> pure (Right (atomTypeForAtom atom))

1012+ Right atom -> pure (atomTypeForAtom atom)

965− Left _ -> pure (Left err)

1013+ Left _ -> throwError err

966−

1014+

967−typeForGraphAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))

1015+typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)

968−typeForGraphAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do

1016+typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do

969− context <- fmap envContext askEnv

970− let funcs = atomFunctions context

1017+ funcs <- atomFunctions . concreteDatabaseContext <$> gfTransForId transId

971 case atomFunctionForName funcName funcs of

1018 case atomFunctionForName funcName funcs of

972− Left err -> pure (Left err)

1019+ Left err -> throwError err

973 Right func -> do

1020 Right func -> do

974 let funcRetType = last (atomFuncType func)

1021 let funcRetType = last (atomFuncType func)

975 funcArgTypes = init (atomFuncType func)

1022 funcArgTypes = init (atomFuncType func)

976− eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs

1023+ argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs

977− case lefts eArgTypes of

978− errs@(_:_) -> pure (Left (someErrors errs))

979− [] -> do

980− let eTvMap = resolveTypeVariables funcArgTypes argTypes

1024+ let eTvMap = resolveTypeVariables funcArgTypes argTypes

981− argTypes = rights eArgTypes

982− case eTvMap of

1025+ case eTvMap of

983− Left err -> pure (Left err)

1026+ Left err -> throwError err

984− Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)

1027+ Right tvMap -> lift $ except $ resolveFunctionReturnValue funcName tvMap funcRetType

985−typeFromAtomExpr attrs (RelationAtomExpr relExpr) = do

1028+typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do

986− relType <- R.local (mergeAttributesIntoRelationalExprState attrs) (typeForRelationalExpr relExpr)

1029+ relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)

987− case relType of

988− Left err -> pure (Left err)

989− Right relType' ->

990− pure (pure (RelationAtomType (attributes relType')))

1030+ pure (RelationAtomType (attributes relType))

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

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

992−typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =

1032+typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =

993− runExceptT $ do

1033+ do

994− argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs

1034+ argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs

995− context <- fmap envContext (lift askEnv)

1035+ tConsMap <- typeConstructorMapping . concreteDatabaseContext <$> gfTransForId tid

996− either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)

1036+ lift $ except $ atomTypeForDataConstructor tConsMap dConsName argsTypes

997

1037

998-- | Validate that the type of the AtomExpr matches the expected type.

1038-- | Validate that the type of the AtomExpr matches the expected type.

999−verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)

1039+verifyGraphRefAtomExprTypes :: Relation -> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType

1000−verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do

1040+verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do

1001− rstate <- lift askEnv

1041+ env <- askEnv

1002 case A.atomTypeForAttributeName attrName (attributes relIn) of

1042 case A.atomTypeForAttributeName attrName (attributes relIn) of

1003− Right aType -> either throwE pure (atomTypeVerify expectedType aType)

1043+ Right aType -> lift $ except $ atomTypeVerify expectedType aType

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

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

1005− let attrs' = stateAttributes rstate in

1045+ let attrs' = envAttributes env in

1006 if attrs' == emptyAttributes then

1046 if attrs' == emptyAttributes then

1007− throwE err

1047+ throwError err

1008 else

1048 else

1009 case A.attributeForName attrName attrs' of

1049 case A.attributeForName attrName attrs' of

1010− Left err' -> throwE err'

1050+ Left err' -> throwError err'

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

1051+ Right attrType -> lift $ except $ atomTypeVerify expectedType (A.atomType attrType)

1052+verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =

1012−verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))

1053+ lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)

1013−verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do

1054+verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) expectedType = do

1014− rstate <- askEnv

1055+ context <- concreteDatabaseContext <$> gfTransForId tid

1015 let functions = atomFunctions context

1056 let functions = atomFunctions context

1016− context = envContext rstate

1017− runExceptT $ do

1018− func <- either throwE pure (atomFunctionForName funcName functions)

1057+ func <- lift $ except $ atomFunctionForName funcName functions

1019− let expectedArgTypes = atomFuncType func

1058+ let expectedArgTypes = atomFuncType func

1020− funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case runReader (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of

1059+ funcArgVerifier (atomExpr, expectedType2, argCount) = do

1060+ let handler :: RelationalError -> GraphRefRelationalExprM AtomType

1021− Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)

1061+ handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)

1022− Left err -> throwE err

1062+ handler err = throwError err

1023− Right x -> pure x

1063+ verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler

1024− ) $ zip3 funcArgExprs expectedArgTypes [1..]

1064+ funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]

1025− if length funcArgTypes /= length expectedArgTypes - 1 then

1065+ if length funcArgTypes /= length expectedArgTypes - 1 then

1026− throwE (AtomTypeCountError funcArgTypes expectedArgTypes)

1066+ throwError (AtomTypeCountError funcArgTypes expectedArgTypes)

1027 else

1067 else

1028− either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))

1068+ lift $ except $ atomTypeVerify expectedType (last expectedArgTypes)

1029−verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do

1069+verifyGraphRefAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType =

1030− rstate <- lift askEnv

1070+ do

1031− relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))

1071+ let mergedAttrsEnv e = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn) e

1072+ relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr)

1032− either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))

1073+ lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType))

1033−verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do

1074+verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do

1034− cType <- liftE (typeFromAtomExpr (attributes rel) cons)

1075+ cType <- typeForGraphRefAtomExpr (attributes rel) cons

1035− either throwE pure (atomTypeVerify expectedType cType)

1076+ lift $ except $ atomTypeVerify expectedType cType

1036

1077

1037-- | Look up the type's name and create a new attribute.

1078-- | Look up the type's name and create a new attribute.

1038−evalGraphRefAttrExpr :: GraphRefAttributeExpr -> RelationalExprState (Either RelationalError Attribute)

1079+evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute

1039evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do

1080evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do

1040− graph <- re_graph <$> askEnv

1081+ tConsMap <- typeConstructorMapping . concreteDatabaseContext <$> gfTransForId transId

1041− case transactionForId transId graph of

1042− Left err -> pure (Left err)

1043− Right trans -> do

1044− let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)

1045− validate = do

1046− aType <- atomTypeForTypeConstructorValidate True tCons tConsMap M.empty

1082+ aType <- lift $ except $ atomTypeForTypeConstructorValidate True tCons tConsMap M.empty

1047− validateAtomType aType tConsMap

1083+ lift $ except $ validateAtomType aType tConsMap

1048− pure aType

1049− case validate of

1050− Left err -> pure (Left err)

1051− Right aType ->

1052− pure $ Right (Attribute attrName aType)

1084+ pure $ Attribute attrName aType

1053

1085

1054−evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure $ Right attr

1086+evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure attr

1055

1087

1056−evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)

1088+evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple

1057−evalTupleExpr mAttrs (TupleExpr tupMap) = do

1089+evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do

1058− context <- fmap envContext askEnv

1059− runExceptT $ do

1060 -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority

1090 -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority

1061 -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed

1091 -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed

1062− let attrs = fromMaybe A.emptyAttributes mAttrs

1092+ let attrs = fromMaybe A.emptyAttributes mAttrs

1063− attrAtoms <- mapM (\(attrName, aExpr) -> do

1093+ resolveOneAtom (attrName, aExpr) =

1094+ do

1064− --provided when the relation header is available

1095+ --provided when the relation header is available

1065− let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs

1096+ let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs

1066− unresolvedType <- liftE (typeFromAtomExpr attrs aExpr)

1097+ unresolvedType <- typeForGraphRefAtomExpr attrs aExpr

1067− resolvedType <- case eExpectedAtomType of

1098+ resolvedType <- case eExpectedAtomType of

1068 Left _ -> pure unresolvedType

1099 Left _ -> pure unresolvedType

1069− Right typeHint -> either throwE pure (resolveAtomType typeHint unresolvedType)

1100+ Right typeHint -> lift $ except $ resolveAtomType typeHint unresolvedType

1070 --resolve atom typevars based on resolvedType?

1101 --resolve atom typevars based on resolvedType?

1071− newAtom <- liftE (evalAtomExpr emptyTuple aExpr)

1102+ newAtom <- evalGraphRefAtomExpr emptyTuple aExpr

1072− pure (attrName, newAtom, resolvedType)

1103+ pure (attrName, newAtom, resolvedType)

1073− ) (M.toList tupMap)

1104+ attrAtoms <- mapM resolveOneAtom (M.toList tupMap)

1074− let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms

1105+ let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms

1075− atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms

1106+ atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms

1076− tup = mkRelationTuple tupAttrs atoms

1107+ tup = mkRelationTuple tupAttrs atoms

1077− tConss = typeConstructorMapping context

1078− finalAttrs = fromMaybe tupAttrs mAttrs

1108+ finalAttrs = fromMaybe tupAttrs mAttrs

1079 --verify that the attributes match

1109 --verify that the attributes match

1080− when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)

1110+ when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs)

1111+ --we can't resolve types here- they have to be resolved at the atom level where the graph ref is held

1081− tup' <- either throwE pure (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))

1112+-- tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))

1113+ let tup' = reorderTuple finalAttrs tup

1114+ --TODO: restore type resolution

1082− _ <- either throwE pure (validateTuple tup' tConss)

1115+-- _ <- lift $ except (validateTuple tup' tConss)

1083− pure tup'

1116+ pure tup'

1084

1117

1118+{-

1085−evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName))

1119+evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprM (Either RelationalError (S.Set AttributeName))

1086evalAttributeNames attrNames expr = do

1120evalAttributeNames attrNames expr = do

1087 eExprType <- typeForRelationalExpr expr

1121 eExprType <- typeForRelationalExpr expr

1088 case eExprType of

1122 case eExprType of

1089− Left err -> pure (Left err)

1123+ Left err -> throwError err

1090 Right exprTyp -> do

1124 Right exprTyp -> do

1091 let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))

1125 let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))

1092 case attrNames of

1126 case attrNames of

@@ -1129,14 +1163,15 @@ evalAttributeNames attrNames expr = do

1129 case eAttrExprType of

1163 case eAttrExprType of

1130 Left err -> pure (Left err)

1164 Left err -> pure (Left err)

1131 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

1165 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

1166+-}

1132

1167

1133−evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> TransactionGraph -> Either RelationalError Relation

1168+evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

1134--evalGraphRefRelationalExpr (MakeRelationaFromExprs

1169--evalGraphRefRelationalExpr (MakeRelationaFromExprs

1135−evalGraphRefRelationalExpr (RelationVariable name tid) graph = do

1170+evalGraphRefRelationalExpr (RelationVariable name tid) = do

1136− ctx <- dbContextForTransId tid graph

1171+ ctx <- concreteDatabaseContext <$> gfTransForId tid

1137 case M.lookup name (relationVariables ctx) of

1172 case M.lookup name (relationVariables ctx) of

1138− Nothing -> Left (RelVarNotDefinedError name)

1173+ Nothing -> throwError (RelVarNotDefinedError name)

1139− Just rv -> evalGraphRefRelationalExpr rv graph

1174+ Just rv -> evalGraphRefRelationalExpr rv

1140

1175

1141

1176

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

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

@@ -1155,165 +1190,64 @@ transactionForId tid graph

1155 where

1190 where

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

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

1157

1192

1158−processRestrictionPredicateExpr :: RestrictionPredicateExpr -> RelationalExprState GraphRefRestrictionPredicateExpr

1159−processRestrictionPredicateExpr TruePredicate = pure TruePredicate

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

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

1162−processRestrictionPredicateExpr (NotPredicate a) = NotPredicate <$> processRestrictionPredicateExpr a

1163−processRestrictionPredicateExpr (RelationalExprPredicate expr) =

1164− RelationalExprPredicate <$> processRelationalExpr expr

1165−processRestrictionPredicateExpr (AtomExprPredicate expr) =

1166− AtomExprPredicate <$> processAtomExpr expr

1167−processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) =

1168− AttributeEqualityPredicate nam <$> processAtomExpr expr

1169−

1170−processExtendTupleExpr :: ExtendTupleExpr -> RelationalExprState GraphRefExtendTupleExpr

1171−processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =

1172− AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr

1173−

1174−typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprR (Either RelationalError Relation)

1193+typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

1175−typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = pure $ mkRelation attrs emptyTupleSet

1194+typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet

1176−typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (Right (emptyRelationWithAttrs (attributes rel)))

1195+typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))

1177typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =

1196typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) =

1178 case mAttrExprs of

1197 case mAttrExprs of

1179 Just attrExprs -> do

1198 Just attrExprs -> do

1180− eAttrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs

1199+ attrs <- mapM (\e -> evalGraphRefAttributeExpr e) attrExprs

1181− case lefts eAttrs of

1182− [] -> pure (Right (emptyRelationWithAttrs (attributesFromList (rights eAttrs))))

1200+ pure (emptyRelationWithAttrs (attributesFromList attrs))

1183− _ -> pure (Left (someErrors (lefts eAttrs)))

1184typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

1201typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do

1185− graph <- R.ask

1186− let eTrans = transactionForId tid graph

1187− case eTrans of

1188− Left err -> pure (Left err)

1189− Right trans -> do

1190− let relVars = relationVariables (concreteDatabaseContext trans)

1202+ relVars <- relationVariables . concreteDatabaseContext <$> gfTransForId tid

1191− case M.lookup rvName relVars of

1203+ case M.lookup rvName relVars of

1192− Nothing -> pure (Left (RelVarNotDefinedError rvName))

1204+ Nothing -> throwError (RelVarNotDefinedError rvName)

1193− Just rvExpr -> typeForGraphRefRelationalExpr rvExpr

1205+ Just rvExpr -> typeForGraphRefRelationalExpr rvExpr

1194typeForGraphRefRelationalExpr (Project attrNames expr) = do

1206typeForGraphRefRelationalExpr (Project attrNames expr) = do

1195− eExprType <- typeForGraphRefRelationalExpr expr

1207+ exprType <- typeForGraphRefRelationalExpr expr

1196− case eExprType of

1197− Left err -> pure (Left err)

1198− Right exprType -> do

1199− eProjectionAttrs <- evalGraphRefAttributeNames attrNames expr

1208+ projectionAttrs <- evalGraphRefAttributeNames attrNames expr

1200− pure $ case eProjectionAttrs of

1201− Left err -> Left err

1202− Right projectionAttrs -> project projectionAttrs exprType

1209+ lift $ except $ project projectionAttrs exprType

1203

1210

1204−evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprR (Either RelationalError (S.Set AttributeName))

1211+evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)

1205evalGraphRefAttributeNames attrNames expr = do

1212evalGraphRefAttributeNames attrNames expr = do

1206− eExprType <- typeForGraphRefRelationalExpr expr

1213+ exprType <- typeForGraphRefRelationalExpr expr

1207− case eExprType of

1208− Left err -> pure (Left err)

1209− Right exprTyp -> do

1210− let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))

1214+ let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprType)))

1211− case attrNames of

1215+ case attrNames of

1212− AttributeNames names ->

1216+ AttributeNames names ->

1213− case A.projectionAttributesForNames names (attributes exprTyp) of

1217+ case A.projectionAttributesForNames names (attributes exprType) of

1214− Left err -> pure (Left err)

1218+ Left err -> throwError err

1215− Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))

1219+ Right attrs -> pure (S.fromList (V.toList (A.attributeNames attrs)))

1216

1220

1217− InvertedAttributeNames names -> do

1221+ InvertedAttributeNames names -> do

1218 let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet

1222 let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet

1219 if not (S.null nonExistentAttributeNames) then

1223 if not (S.null nonExistentAttributeNames) then

1220− pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))

1224+ throwError (AttributeNamesMismatchError nonExistentAttributeNames)

1221 else

1225 else

1222− pure (pure (A.nonMatchingAttributeNameSet names typeNameSet))

1226+ pure (A.nonMatchingAttributeNameSet names typeNameSet)

1223−

1224− UnionAttributeNames namesA namesB -> do

1225− eNameSetA <- evalGraphRefAttributeNames namesA expr

1226− case eNameSetA of

1227− Left err -> pure (Left err)

1228− Right nameSetA -> do

1229− eNameSetB <- evalGraphRefAttributeNames namesB expr

1230− case eNameSetB of

1231− Left err -> pure (Left err)

1232− Right nameSetB ->

1233− pure (Right (S.union nameSetA nameSetB))

1234

1227

1235− IntersectAttributeNames namesA namesB -> do

1228+ UnionAttributeNames namesA namesB -> do

1236− eNameSetA <- evalGraphRefAttributeNames namesA expr

1229+ nameSetA <- evalGraphRefAttributeNames namesA expr

1237− case eNameSetA of

1238− Left err -> pure (Left err)

1239− Right nameSetA -> do

1240− eNameSetB <- evalGraphRefAttributeNames namesB expr

1230+ nameSetB <- evalGraphRefAttributeNames namesB expr

1241− case eNameSetB of

1242− Left err -> pure (Left err)

1243− Right nameSetB ->

1244− pure (Right (S.intersection nameSetA nameSetB))

1231+ pure (S.union nameSetA nameSetB)

1245

1232

1246− RelationalExprAttributeNames attrExpr -> do

1233+ IntersectAttributeNames namesA namesB -> do

1247− eAttrExprType <- typeForGraphRefRelationalExpr attrExpr

1234+ nameSetA <- evalGraphRefAttributeNames namesA expr

1248− case eAttrExprType of

1235+ nameSetB <- evalGraphRefAttributeNames namesB expr

1249− Left err -> pure (Left err)

1236+ pure (S.intersection nameSetA nameSetB)

1250− Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

1251

1237

1238+ RelationalExprAttributeNames attrExpr -> do

1239+ attrExprType <- typeForGraphRefRelationalExpr attrExpr

1240+ pure (A.attributeNameSet (attributes attrExprType))

1252

1241

1253−

1254−

1255−processAtomExpr :: AtomExpr -> RelationalExprState GraphRefAtomExpr

1256−processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam

1257−processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom

1258−processAtomExpr (FunctionAtomExpr fName atomExprs ()) = do

1259− tid <- re_currentTransId <$> askEnv

1260− FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> pure tid

1261−processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr

1262−processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> (re_currentTransId <$> askEnv)

1263−

1264−processTupleExpr :: TupleExpr -> RelationalExprState GraphRefTupleExpr

1265−processTupleExpr (TupleExpr tMap) =

1266− TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)

1267−

1268−evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprR (Either RelationalError Attribute)

1242+evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute

1269evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

1243evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do

1270− graph <- R.ask

1271− case transactionForId tid graph of

1272− Left err -> pure (Left err)

1273− Right trans -> do

1274− let tConsMap = typeConstructorMapping (concreteDatabaseContext trans)

1244+ tConsMap <- typeConstructorMapping . concreteDatabaseContext <$> gfTransForId tid

1275− case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of

1245+ case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of

1276− Left err -> pure (Left err)

1246+ Left err -> throwError err

1277− Right aType -> do

1247+ Right aType -> do

1278− case validateAtomType aType tConsMap of

1248+ case validateAtomType aType tConsMap of

1279− Left err -> pure (Left err)

1249+ Left err -> throwError err

1280− Right _ -> pure (Right (Attribute attrName aType))

1250+ Right _ -> pure (Attribute attrName aType)

1281−

1282−--convert AttributeExpr to GraphRefAttributeExpr

1283−processAttributeExpr :: AttributeExpr -> RelationalExprState GraphRefAttributeExpr

1284−processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) = do

1285− tid <- re_currentTransId <$> askEnv

1286− pure $ AttributeAndTypeNameExpr nam tCons tid

1287−processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr

1288−

1289−-- convert a RelationalExpr into a GraphRefRelationalExpr using the current trans Id

1290−-- can this be done without any RelationalErrors as opposed to evalRelationalExpr?

1291−processRelationalExpr :: RelationalExpr -> RelationalExprState GraphRefRelationalExpr

1292−processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do

1293− mAttrs' <- case mAttrs of

1294− Nothing -> pure Nothing

1295− Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''

1296− MakeRelationFromExprs mAttrs' <$> mapM processTupleExpr tupleExprs

1297−processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)

1298−processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)

1299−processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> fmap re_currentTransId askEnv

1300−processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr

1301−processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB

1302−processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB

1303−processRelationalExpr (Rename attrA attrB expr) =

1304− Rename attrA attrB <$> processRelationalExpr expr

1305−processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB

1306−processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr

1307−processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr

1308−processRelationalExpr (Restrict pred expr) = Restrict <$> processRestrictionPredicateExpr pred <*> processRelationalExpr expr

1309−processRelationalExpr (Equals exprA exprB) =

1310− Equals <$> processRelationalExpr exprA <*> processRelationalExpr exprB

1311−processRelationalExpr (NotEquals exprA exprB) =

1312− NotEquals <$> processRelationalExpr exprA <*> processRelationalExpr exprB

1313−processRelationalExpr (Extend extendExpr expr) =

1314− Extend <$> processExtendTupleExpr extendExpr <*> processRelationalExpr expr

1315−processRelationalExpr (With macros expr) =

1316− With <$> mapM (\(nam, wexpr) -> (,) nam <$> processRelationalExpr wexpr) macros <*> processRelationalExpr expr

1317

1251

1318mkEmptyRelVars :: RelationVariables -> RelationVariables

1252mkEmptyRelVars :: RelationVariables -> RelationVariables

1319mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

1253mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

@@ -1335,50 +1269,10 @@ mkEmptyRelVars rvMap = M.map mkEmptyRelVar rvMap

1335 mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)

1269 mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)

1336 mkEmptyRelVar (With macros expr) = With (map (\(rv, expr) -> (rv, mkEmptyRelVar expr)) macros) (mkEmptyRelVar expr)

1270 mkEmptyRelVar (With macros expr) = With (map (\(rv, expr) -> (rv, mkEmptyRelVar expr)) macros) (mkEmptyRelVar expr)

1337

1271

1338−processAttributeNames :: AttributeNames -> RelationalExprState GraphRefAttributeNames

1339−processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet

1340−processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB

1341−processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB

1342−processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr

1343−

1344−processDatabaseContextExpr :: DatabaseContextExpr -> RelationalExprState GraphRefDatabaseContextExpr

1345−processDatabaseContextExpr expr =

1346− case expr of

1347− NoOperation -> pure NoOperation

1348− Define nam attrExprs -> Define nam <$> mapM processAttributeExpr attrExprs

1349− Undefine nam -> pure (Undefine nam)

1350− Assign nam rexpr -> Assign nam <$> processRelationalExpr rexpr

1351− Insert nam rexpr -> Insert nam <$> processRelationalExpr rexpr

1352− Delete nam pred -> Delete nam <$> processRestrictionPredicateExpr pred

1353− Update nam attrMap pred -> Update nam attrMap <$> processRestrictionPredicateExpr pred

1354−

1355− AddInclusionDependency nam dep -> pure (AddInclusionDependency nam dep)

1356− RemoveInclusionDependency nam -> pure (RemoveInclusionDependency nam)

1357− AddNotification nam exprA exprB exprC -> pure (AddNotification nam exprA exprB exprC)

1358− RemoveNotification nam -> pure (RemoveNotification nam)

1359− AddTypeConstructor tyDef consDefs -> pure (AddTypeConstructor tyDef consDefs)

1360− RemoveTypeConstructor tyName -> pure (RemoveTypeConstructor tyName)

1361−

1362− RemoveAtomFunction aFuncName -> pure (RemoveAtomFunction aFuncName)

1363− RemoveDatabaseContextFunction funcName -> pure (RemoveDatabaseContextFunction funcName)

1364− ExecuteDatabaseContextFunction funcName atomExprs -> ExecuteDatabaseContextFunction funcName <$> mapM processAtomExpr atomExprs

1365− MultipleExpr exprs -> MultipleExpr <$> mapM processDatabaseContextExpr exprs

1366

1272

1367dbErr :: RelationalError -> DatabaseContextEvalMonad ()

1273dbErr :: RelationalError -> DatabaseContextEvalMonad ()

1368dbErr err = lift (except (Left err))

1274dbErr err = lift (except (Left err))

1369

1275

1370−processDatabaseContextIOExpr :: DatabaseContextIOExpr -> RelationalExprState GraphRefDatabaseContextIOExpr

1371−processDatabaseContextIOExpr (AddAtomFunction f tcs sc) =

1372− pure (AddAtomFunction f tcs sc)

1373−processDatabaseContextIOExpr (LoadAtomFunctions mod fun file) =

1374− pure (LoadAtomFunctions mod fun file)

1375−processDatabaseContextIOExpr (AddDatabaseContextFunction mod fun path) =

1376− pure (AddDatabaseContextFunction mod fun path)

1377−processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod fun path) =

1378− pure (LoadDatabaseContextFunctions mod fun path)

1379−processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =

1380− CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range

1381−

1382-- | Return a Relation describing the relation variables.

1276-- | Return a Relation describing the relation variables.

1383relationVariablesAsRelation :: RelationVariables -> TransactionGraph -> Either RelationalError Relation

1277relationVariablesAsRelation :: RelationVariables -> TransactionGraph -> Either RelationalError Relation

1384relationVariablesAsRelation relVarMap graph = do

1278relationVariablesAsRelation relVarMap graph = do

@@ -1386,7 +1280,8 @@ relationVariablesAsRelation relVarMap graph = do

1386 attrs = A.attributesFromList [Attribute "name" TextAtomType,

1280 attrs = A.attributesFromList [Attribute "name" TextAtomType,

1387 Attribute "attributes" (RelationAtomType subrelAttrs)]

1281 Attribute "attributes" (RelationAtomType subrelAttrs)]

1388 mkRvDesc (rvName, gfExpr) = do

1282 mkRvDesc (rvName, gfExpr) = do

1283+ let gfEnv = freshGraphRefRelationalExprEnv graph

1389− gfType <- runReader (typeForGraphRefRelationalExpr gfExpr) graph

1284+ gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

1390 pure (rvName, gfType)

1285 pure (rvName, gfType)

1391 relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]

1286 relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]

1392 attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]

1287 attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]

src/lib/ProjectM36/Server/ParseArgs.hs+3−1

@@ -3,7 +3,9 @@ import ProjectM36.Base

3import ProjectM36.Client

4import Options.Applicative

5import ProjectM36.Server.Config

6+#if __GLASGOW_HASKELL__ <= 802

6−--import Data.Monoid

7+import Data.Monoid

8+#endif

8parseArgsWithDefaults :: ServerConfig -> Parser ServerConfig

10parseArgsWithDefaults :: ServerConfig -> Parser ServerConfig

9parseArgsWithDefaults defaults = ServerConfig <$>

11parseArgsWithDefaults defaults = ServerConfig <$>

src/lib/ProjectM36/StaticOptimizer.hs+76−73

@@ -6,11 +6,13 @@ import ProjectM36.RelationalExpression

6import ProjectM36.TransGraphRelationalExpression as TGRE

7import ProjectM36.Error

8import ProjectM36.Transaction

9+import ProjectM36.NormalizeExpr

9import qualified ProjectM36.Attribute as A

10import qualified ProjectM36.Attribute as A

10import qualified ProjectM36.AttributeNames as AS

11import qualified ProjectM36.AttributeNames as AS

11import ProjectM36.TupleSet

12import ProjectM36.TupleSet

12import Control.Monad.State

13import Control.Monad.State

13−import Control.Monad.Trans.Reader

14+import Control.Monad.Reader

15+import Control.Monad.Except

14import Control.Monad.Trans.Except

16import Control.Monad.Trans.Except

15import Data.Functor.Identity

17import Data.Functor.Identity

16import qualified Data.Map as M

18import qualified Data.Map as M

@@ -26,30 +28,37 @@ type GraphRefStaticOptimizerMonad a = ReaderT TransactionGraph (ExceptT Relation

26-- | A temporary function to be replaced by IO-based implementation.

28-- | A temporary function to be replaced by IO-based implementation.

27optimizeAndEvalRelationalExpr :: RelationalExprEnv -> RelationalExpr -> Either RelationalError Relation

29optimizeAndEvalRelationalExpr :: RelationalExprEnv -> RelationalExpr -> Either RelationalError Relation

28optimizeAndEvalRelationalExpr env expr = do

30optimizeAndEvalRelationalExpr env expr = do

29− let gfExpr = runReader (processRelationalExpr expr) env

31+ let gfExpr = runProcessExprM tid graph (processRelationalExpr expr)

32+ tid = re_currentTransId env

33+ graph = re_graph env

34+ gfEnv = freshGraphRefRelationalExprEnv graph

30 optExpr <- runGraphRefStaticOptimizerMonad (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr)

35 optExpr <- runGraphRefStaticOptimizerMonad (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr)

31− evalGraphRefRelationalExpr optExpr (re_graph env)

36+ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

33optimizeAndEvalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContextEvalMonad ()

38optimizeAndEvalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContextEvalMonad ()

34optimizeAndEvalDatabaseContextExpr expr = do

39optimizeAndEvalDatabaseContextExpr expr = do

35− env <- dbcRelationalExprEnv

40+ tid <- dce_transId <$> ask

41+ graph <- dce_graph <$> ask

36− let gfExpr = runReader (processDatabaseContextExpr expr) env

42+ let gfExpr = runProcessExprM tid graph (processDatabaseContextExpr expr)

37− eOptExpr = runGraphRefStaticOptimizerMonad (re_graph env) (optimizeGraphRefDatabaseContextExpr gfExpr)

43+ eOptExpr = runGraphRefStaticOptimizerMonad graph (optimizeGraphRefDatabaseContextExpr gfExpr)

38 case eOptExpr of

44 case eOptExpr of

39− Left err -> lift (except (Left err))

45+ Left err -> throwError err

40 Right optExpr -> evalGraphRefDatabaseContextExpr optExpr

46 Right optExpr -> evalGraphRefDatabaseContextExpr optExpr

42optimizeAndEvalTransGraphRelationalExpr :: TransactionGraph -> TransGraphRelationalExpr -> Either RelationalError Relation

48optimizeAndEvalTransGraphRelationalExpr :: TransactionGraph -> TransGraphRelationalExpr -> Either RelationalError Relation

43optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do

49optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do

44 gfExpr <- TGRE.process (TransGraphEvalEnv graph) tgExpr

50 gfExpr <- TGRE.process (TransGraphEvalEnv graph) tgExpr

45 optExpr <- runGraphRefStaticOptimizerMonad graph (fullOptimizeGraphRefRelationalExpr gfExpr)

51 optExpr <- runGraphRefStaticOptimizerMonad graph (fullOptimizeGraphRefRelationalExpr gfExpr)

52+ let gfEnv = freshGraphRefRelationalExprEnv graph

46− evalGraphRefRelationalExpr optExpr graph

53+ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)

48optimizeAndEvalDatabaseContextIOExpr :: DatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

55optimizeAndEvalDatabaseContextIOExpr :: DatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())

49optimizeAndEvalDatabaseContextIOExpr expr = do

56optimizeAndEvalDatabaseContextIOExpr expr = do

50− reEnv <- getDBCIORelationalExprEnv

57+ env <- getDBCIORelationalExprEnv

51− let gfExpr = runReader (processDatabaseContextIOExpr expr) reEnv

58+ let gfExpr = runProcessExprM tid graph (processDatabaseContextIOExpr expr)

52− eOptExpr = runStaticOptimizerMonad reEnv (optimizeDatabaseContextIOExpr gfExpr)

59+ eOptExpr = runStaticOptimizerMonad env (optimizeDatabaseContextIOExpr gfExpr)

60+ tid = re_currentTransId env

61+ graph = re_graph env

53 case eOptExpr of

62 case eOptExpr of

54 Left err -> pure (Left err)

63 Left err -> pure (Left err)

55 Right optExpr ->

64 Right optExpr ->

@@ -86,10 +95,11 @@ optimizeGraphRefRelationalExpr e@(RelationVariable _ _) = pure e

87--remove project of attributes which removes no attributes

96--remove project of attributes which removes no attributes

88optimizeGraphRefRelationalExpr (Project attrNameSet expr) = do

97optimizeGraphRefRelationalExpr (Project attrNameSet expr) = do

89− reenv <- ask

98+ graph <- ask

90− let relType = runReader (typeForGraphRefRelationalExpr expr) reenv

99+ let relType = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)

100+ gfEnv = freshGraphRefRelationalExprEnv graph

91 case relType of

101 case relType of

92− Left err -> lift $ except (Left err)

102+ Left err -> throwError err

93 Right relType2

103 Right relType2

94 | AS.all == attrNameSet ->

104 | AS.all == attrNameSet ->

95 optimizeGraphRefRelationalExpr expr

105 optimizeGraphRefRelationalExpr expr

@@ -124,13 +134,14 @@ optimizeGraphRefRelationalExpr (Join exprA exprB) = do

124 pure (Join optExprA optExprB)

134 pure (Join optExprA optExprB)

125

135

126optimizeGraphRefRelationalExpr (Difference exprA exprB) = do

136optimizeGraphRefRelationalExpr (Difference exprA exprB) = do

127− env <- ask

137+ graph <- ask

128 optExprA <- optimizeGraphRefRelationalExpr exprA

138 optExprA <- optimizeGraphRefRelationalExpr exprA

129 optExprB <- optimizeGraphRefRelationalExpr exprB

139 optExprB <- optimizeGraphRefRelationalExpr exprB

130 if optExprA == optExprB then do --A difference A == A where false

140 if optExprA == optExprB then do --A difference A == A where false

131− let eEmptyRel = runReader (typeForGraphRefRelationalExpr optExprA) env

141+ let eEmptyRel = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr optExprA)

142+ gfEnv = freshGraphRefRelationalExprEnv graph

132 case eEmptyRel of

143 case eEmptyRel of

133− Left err -> lift (except (Left err))

144+ Left err -> throwError err

134 Right emptyRel -> pure (ExistingRelation emptyRel)

145 Right emptyRel -> pure (ExistingRelation emptyRel)

135 else

146 else

136 pure (Difference optExprA optExprB)

147 pure (Difference optExprA optExprB)

@@ -150,9 +161,10 @@ optimizeGraphRefRelationalExpr (Restrict predicate expr) = do

150 case optimizedPredicate of

161 case optimizedPredicate of

151 optimizedPredicate' | isTrueExpr optimizedPredicate' -> optimizeGraphRefRelationalExpr expr -- remove predicate entirely

162 optimizedPredicate' | isTrueExpr optimizedPredicate' -> optimizeGraphRefRelationalExpr expr -- remove predicate entirely

152 optimizedPredicate' | isFalseExpr optimizedPredicate' -> do -- replace where false predicate with empty relation with attributes from relexpr

163 optimizedPredicate' | isFalseExpr optimizedPredicate' -> do -- replace where false predicate with empty relation with attributes from relexpr

153− let attributesRel = runReader (typeForGraphRefRelationalExpr expr) graph

164+ let attributesRel = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)

165+ gfEnv = freshGraphRefRelationalExprEnv graph

154 case attributesRel of

166 case attributesRel of

155− Left err -> lift (except (Left err))

167+ Left err -> throwError err

156 Right attributesRelA -> pure $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet

168 Right attributesRelA -> pure $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet

157 | otherwise -> do

169 | otherwise -> do

158 optSubExpr <- optimizeGraphRefRelationalExpr expr

170 optSubExpr <- optimizeGraphRefRelationalExpr expr

@@ -321,61 +333,52 @@ applyStaticJoinElimination expr@(Project attrNameSet (Join exprA exprB)) = do

321 -- the sub exprs are in different transactions or none at all, so we cannot extract inclusion dependencies across transaction boundaries

333 -- the sub exprs are in different transactions or none at all, so we cannot extract inclusion dependencies across transaction boundaries

322 Nothing -> pure expr

334 Nothing -> pure expr

323 Just commonTransId -> do

335 Just commonTransId -> do

324− let typeForExpr e = runReader (typeForGraphRefRelationalExpr e) graph

336+ let typeForExpr e = lift $ except $ runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr e)

325− eProjType = typeForExpr expr

337+ gfEnv = freshGraphRefRelationalExprEnv graph

326− eTypeA = typeForExpr exprA

338+ projType <- typeForExpr expr

327− eTypeB = typeForExpr exprB

339+ typeA <- typeForExpr exprA

328− liftErr = lift . except . Left

340+ typeB <- typeForExpr exprB

329− case eProjType of

330− Left err -> liftErr err

331− Right projType ->

332− case eTypeA of

333− Left err -> liftErr err

334− Right typeA ->

335− case eTypeB of

336− Left err -> liftErr err

337− Right typeB -> do

338− let matchesProjectionAttributes

341+ let matchesProjectionAttributes

339− | attrNames projType `S.isSubsetOf` attrNames typeA =

342+ | attrNames projType `S.isSubsetOf` attrNames typeA =

340− Just ((exprA, typeA), (exprB, typeB))

343+ Just ((exprA, typeA), (exprB, typeB))

341− | attrNames projType `S.isSubsetOf` attrNames typeB =

344+ | attrNames projType `S.isSubsetOf` attrNames typeB =

342− Just ((exprB, typeB), (exprA, typeA))

345+ Just ((exprB, typeB), (exprA, typeA))

343− | otherwise =

346+ | otherwise =

344− Nothing

347+ Nothing

345− attrNames = A.attributeNameSet . attributes

348+ attrNames = A.attributeNameSet . attributes

346− case matchesProjectionAttributes of

349+ case matchesProjectionAttributes of

347− Nothing -> -- this optimization does not apply

350+ Nothing -> -- this optimization does not apply

348− pure expr

351+ pure expr

349− Just ((joinedExpr, joinedType), (unjoinedExpr, _)) -> do

352+ Just ((joinedExpr, joinedType), (unjoinedExpr, _)) -> do

350− --lookup transaction

353+ --lookup transaction

351− trans <- lift $ except (transactionForId commonTransId graph)

354+ trans <- lift $ except (transactionForId commonTransId graph)

352− --scan inclusion dependencies for a foreign key relationship

355+ --scan inclusion dependencies for a foreign key relationship

353− let incDeps = inclusionDependencies commonContext

356+ let incDeps = inclusionDependencies commonContext

354− commonContext = concreteDatabaseContext trans

357+ commonContext = concreteDatabaseContext trans

355− reEnv = mkRelationalExprEnv commonContext commonTransId graph

358+ reEnv = mkRelationalExprEnv commonContext commonTransId graph

356− fkConstraint = foldM isFkConstraint False incDeps

359+ fkConstraint = foldM isFkConstraint False incDeps

357− --search for matching fk constraint

360+ --search for matching fk constraint

358− isFkConstraint acc (InclusionDependency (Project subAttrNames subrv) (Project _ superrv)) = do

361+ isFkConstraint acc (InclusionDependency (Project subAttrNames subrv) (Project _ superrv)) = do

359− let gfSubAttrNames = runReader (processAttributeNames subAttrNames) reEnv

362+ let gfSubAttrNames = processM (processAttributeNames subAttrNames)

360− gfSubRv = runReader (processRelationalExpr subrv) reEnv

363+ gfSubRv = processM (processRelationalExpr subrv)

361− gfSuperRv = runReader (processRelationalExpr superrv) reEnv

364+ gfSuperRv = processM (processRelationalExpr superrv)

362−

365+ processM = runProcessExprM commonTransId graph

366+ gfEnv = freshGraphRefRelationalExprEnv graph

363− case runReader (evalGraphRefAttributeNames gfSubAttrNames expr) graph of

367+ case runGraphRefRelationalExprM gfEnv (evalGraphRefAttributeNames gfSubAttrNames expr) of

364− Left _ -> pure acc

368+ Left _ -> pure acc

365− Right subAttrNameSet ->

369+ Right subAttrNameSet ->

366− pure (acc || (joinedExpr == gfSubRv &&

370+ pure (acc || (joinedExpr == gfSubRv &&

367− unjoinedExpr == gfSuperRv &&

371+ unjoinedExpr == gfSuperRv &&

368− -- the fk attribute is one of the projection attributes

372+ -- the fk attribute is one of the projection attributes

369− A.attributeNamesContained subAttrNameSet (A.attributeNameSet (attributes joinedType))

373+ A.attributeNamesContained subAttrNameSet (A.attributeNameSet (attributes joinedType))

370 ))

374 ))

371− isFkConstraint acc _ = pure acc

375+ isFkConstraint acc _ = pure acc

372− case fkConstraint of

376+ case fkConstraint of

373− Right True -> --join elimination optimization applies

377+ Right True -> --join elimination optimization applies

374− optimizeGraphRefRelationalExpr (Project attrNameSet joinedExpr)

378+ optimizeGraphRefRelationalExpr (Project attrNameSet joinedExpr)

375− Right False -> --join elimination optimization does not apply

379+ Right False -> --join elimination optimization does not apply

376− pure expr

380+ pure expr

377− Left err ->

381+ Left err -> throwError err

378− lift $ except (Left err)

379

382

380applyStaticJoinElimination expr = pure expr

383applyStaticJoinElimination expr = pure expr

381

384

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

@@ -23,9 +23,11 @@ import qualified Data.Text as T

23import GHC.Generics

24import Data.Binary

25import Data.Either (lefts, rights, isRight)

26−--import Data.Monoid

27import Control.Arrow

26import Control.Arrow

28import Data.Maybe

27import Data.Maybe

28+#if __GLASGOW_HASKELL__ <= 802

29+import Data.Monoid

30+#endif

30{-

32{-

31--import Debug.Trace

33--import Debug.Trace

src/lib/ProjectM36/TransactionGraph/Persist.hs+3−1

@@ -24,12 +24,14 @@ import Control.Exception.Base

24import qualified Data.ByteString as BS

25import qualified Data.Text.Encoding as TE

26import Data.ByteString (ByteString)

27−--import Data.Monoid

28import qualified Crypto.Hash.SHA256 as SHA256

27import qualified Crypto.Hash.SHA256 as SHA256

29import Control.Arrow

28import Control.Arrow

30import Data.Time.Clock

29import Data.Time.Clock

31import Data.Text.Read

30import Data.Text.Read

32import System.FilePath.Glob

31import System.FilePath.Glob

32+#if __GLASGOW_HASKELL__ <= 802

33+import Data.Monoid

34+#endif

34type LockFileHash = ByteString

36type LockFileHash = ByteString

src/lib/ProjectM36/Tupleable.hs+3

@@ -23,6 +23,9 @@ import ProjectM36.Error

23import ProjectM36.Tuple

24import ProjectM36.TupleSet

25import qualified Data.Set as S

26+#if __GLASGOW_HASKELL__ <= 802

27+import Data.Monoid

28+#endif

27{-import Data.Binary

30{-import Data.Binary

28import Control.DeepSeq

31import Control.DeepSeq