{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module ProjectM36.RelationalExpression where
import ProjectM36.Relation
import ProjectM36.Tuple
import ProjectM36.TupleSet
import ProjectM36.Base
import qualified Data.UUID as U
import ProjectM36.Error
import ProjectM36.AtomType
import ProjectM36.Attribute (emptyAttributes, attributesFromList)
import ProjectM36.ScriptSession
import ProjectM36.DataTypes.Primitive
import ProjectM36.AtomFunction
import ProjectM36.DatabaseContextFunction
import ProjectM36.Arbitrary
import ProjectM36.GraphRefRelationalExpr
import ProjectM36.Transaction
import qualified ProjectM36.Attribute as A
import qualified Data.Map as M
import qualified Data.HashSet as HS
import qualified Data.Set as S
import Control.Monad.State hiding (join)
import Data.Bifunctor (second)
import Data.Maybe
import Data.Either
import Data.Char (isUpper)
import Data.Time
import qualified Data.List.NonEmpty as NE
import Data.Functor.Identity
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified ProjectM36.TypeConstructorDef as TCD
import qualified Control.Monad.RWS.Strict as RWS
import Control.Monad.RWS.Strict (RWST, execRWST, runRWST)
import Control.Monad.Except hiding (join)
import Control.Monad.Trans.Except (except)
import Control.Monad.Reader as R hiding (join)
import ProjectM36.NormalizeExpr
import ProjectM36.WithNameExpr
import ProjectM36.Function
import Test.QuickCheck
import qualified Data.Functor.Foldable as Fold
import Control.Applicative
#ifdef PM36_HASKELL_SCRIPTING
import GHC hiding (getContext)
import Control.Exception
import GHC.Paths
#endif
data DatabaseContextExprDetails = CountUpdatedTuples
databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc
databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc
databaseContextExprDetailsFunc DatabaseContextExprDetails
CountUpdatedTuples RelationTuple -> Relation -> Relation
_ Relation
relIn = Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs RelationTupleSet
newTups
where
attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
"count" AtomType
IntAtomType]
existingTuple :: RelationTuple
existingTuple = RelationTuple -> Maybe RelationTuple -> RelationTuple
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> RelationTuple
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible counting error in singletonTuple") (Relation -> Maybe RelationTuple
singletonTuple Relation
relIn)
existingCount :: Int
existingCount = case Vector Atom -> Atom
forall a. Vector a -> a
V.head (RelationTuple -> Vector Atom
tupleAtoms RelationTuple
existingTuple) of
IntAtom Int
v -> Int
v
Atom
_ -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible counting error in tupleAtoms"
newTups :: RelationTupleSet
newTups = case Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet
mkTupleSetFromList Attributes
attrs [[Int -> Atom
IntAtom (Int
existingCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)]] of
Left RelationalError
err -> [Char] -> RelationTupleSet
forall a. HasCallStack => [Char] -> a
error ([Char]
"impossible counting error in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RelationalError -> [Char]
forall a. Show a => a -> [Char]
show RelationalError
err)
Right RelationTupleSet
ts -> RelationTupleSet
ts
mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState
mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState
mkDatabaseContextEvalState DatabaseContext
context = DatabaseContextEvalState :: DatabaseContext
-> Map AttributeName ResultAccum
-> DirtyFlag
-> DatabaseContextEvalState
DatabaseContextEvalState {
dbc_context :: DatabaseContext
dbc_context = DatabaseContext
context,
dbc_accum :: Map AttributeName ResultAccum
dbc_accum = Map AttributeName ResultAccum
forall k a. Map k a
M.empty,
dbc_dirty :: DirtyFlag
dbc_dirty = DirtyFlag
False
}
data RelationalExprEnv = RelationalExprEnv {
RelationalExprEnv -> DatabaseContext
re_context :: DatabaseContext,
RelationalExprEnv -> TransactionGraph
re_graph :: TransactionGraph,
:: Maybe (Either RelationTuple Attributes)
}
envTuple :: GraphRefRelationalExprEnv -> RelationTuple
envTuple :: GraphRefRelationalExprEnv -> RelationTuple
envTuple GraphRefRelationalExprEnv
e = RelationTuple -> Either RelationTuple Attributes -> RelationTuple
forall a b. a -> Either a b -> a
fromLeft RelationTuple
emptyTuple (Either RelationTuple Attributes
-> Maybe (Either RelationTuple Attributes)
-> Either RelationTuple Attributes
forall a. a -> Maybe a -> a
fromMaybe (RelationTuple -> Either RelationTuple Attributes
forall a b. a -> Either a b
Left RelationTuple
emptyTuple) (GraphRefRelationalExprEnv
-> Maybe (Either RelationTuple Attributes)
gre_extra GraphRefRelationalExprEnv
e))
envAttributes :: GraphRefRelationalExprEnv -> Attributes
envAttributes :: GraphRefRelationalExprEnv -> Attributes
envAttributes GraphRefRelationalExprEnv
e = Attributes -> Either RelationTuple Attributes -> Attributes
forall b a. b -> Either a b -> b
fromRight Attributes
emptyAttributes (Either RelationTuple Attributes
-> Maybe (Either RelationTuple Attributes)
-> Either RelationTuple Attributes
forall a. a -> Maybe a -> a
fromMaybe (Attributes -> Either RelationTuple Attributes
forall a b. b -> Either a b
Right Attributes
emptyAttributes) (GraphRefRelationalExprEnv
-> Maybe (Either RelationTuple Attributes)
gre_extra GraphRefRelationalExprEnv
e))
instance Show RelationalExprEnv where
show :: RelationalExprEnv -> [Char]
show e :: RelationalExprEnv
e@RelationalExprEnv{} = [Char]
"RelationalExprEnv " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe (Either RelationTuple Attributes) -> [Char]
forall a. Show a => a -> [Char]
show (RelationalExprEnv -> Maybe (Either RelationTuple Attributes)
re_extra RelationalExprEnv
e)
type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a
runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either RelationalError a
runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either RelationalError a
runRelationalExprM RelationalExprEnv
env RelationalExprM a
m = Identity (Either RelationalError a) -> Either RelationalError a
forall a. Identity a -> a
runIdentity (ExceptT RelationalError Identity a
-> Identity (Either RelationalError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (RelationalExprM a
-> RelationalExprEnv -> ExceptT RelationalError Identity a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RelationalExprM a
m RelationalExprEnv
env))
reGraph :: RelationalExprM TransactionGraph
reGraph :: RelationalExprM TransactionGraph
reGraph = (RelationalExprEnv -> TransactionGraph)
-> RelationalExprM TransactionGraph
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RelationalExprEnv -> TransactionGraph
re_graph
reContext :: RelationalExprM DatabaseContext
reContext :: RelationalExprM DatabaseContext
reContext = (RelationalExprEnv -> DatabaseContext)
-> RelationalExprM DatabaseContext
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RelationalExprEnv -> DatabaseContext
re_context
mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv
mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv
mkRelationalExprEnv DatabaseContext
ctx TransactionGraph
graph =
RelationalExprEnv :: DatabaseContext
-> TransactionGraph
-> Maybe (Either RelationTuple Attributes)
-> RelationalExprEnv
RelationalExprEnv
{ re_context :: DatabaseContext
re_context = DatabaseContext
ctx,
re_graph :: TransactionGraph
re_graph = TransactionGraph
graph,
re_extra :: Maybe (Either RelationTuple Attributes)
re_extra = Maybe (Either RelationTuple Attributes)
forall a. Maybe a
Nothing }
askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv = GraphRefRelationalExprM GraphRefRelationalExprEnv
forall r (m :: * -> *). MonadReader r m => m r
R.ask
mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeTuplesIntoGraphRefRelationalExprEnv RelationTuple
tupIn GraphRefRelationalExprEnv
env =
GraphRefRelationalExprEnv
env { gre_extra :: Maybe (Either RelationTuple Attributes)
gre_extra = Maybe (Either RelationTuple Attributes)
forall b. Maybe (Either RelationTuple b)
new_elems }
where
new_elems :: Maybe (Either RelationTuple b)
new_elems = Either RelationTuple b -> Maybe (Either RelationTuple b)
forall a. a -> Maybe a
Just (RelationTuple -> Either RelationTuple b
forall a b. a -> Either a b
Left RelationTuple
newTuple)
mergedTupMap :: Map AttributeName Atom
mergedTupMap = Map AttributeName Atom
-> Map AttributeName Atom -> Map AttributeName Atom
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (RelationTuple -> Map AttributeName Atom
tupleToMap RelationTuple
tupIn) (RelationTuple -> Map AttributeName Atom
tupleToMap (GraphRefRelationalExprEnv -> RelationTuple
envTuple GraphRefRelationalExprEnv
env))
newTuple :: RelationTuple
newTuple = Map AttributeName Atom -> RelationTuple
mkRelationTupleFromMap Map AttributeName Atom
mergedTupMap
mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeAttributesIntoGraphRefRelationalExprEnv Attributes
attrsIn GraphRefRelationalExprEnv
e = GraphRefRelationalExprEnv
e { gre_extra :: Maybe (Either RelationTuple Attributes)
gre_extra = Maybe (Either RelationTuple Attributes)
forall a. Maybe (Either a Attributes)
newattrs }
where
newattrs :: Maybe (Either a Attributes)
newattrs = Either a Attributes -> Maybe (Either a Attributes)
forall a. a -> Maybe a
Just (Attributes -> Either a Attributes
forall a b. b -> Either a b
Right (Attributes -> Attributes -> Attributes
A.union Attributes
attrsIn (GraphRefRelationalExprEnv -> Attributes
envAttributes GraphRefRelationalExprEnv
e)))
type ResultAccumName = StringType
type ResultAccumFunc = (RelationTuple -> Relation -> Relation) -> Relation -> Relation
data ResultAccum = ResultAccum { ResultAccum -> ResultAccumFunc
resultAccumFunc :: ResultAccumFunc,
ResultAccum -> Relation
resultAccumResult :: Relation
}
data DatabaseContextEvalState = DatabaseContextEvalState {
DatabaseContextEvalState -> DatabaseContext
dbc_context :: DatabaseContext,
DatabaseContextEvalState -> Map AttributeName ResultAccum
dbc_accum :: M.Map ResultAccumName ResultAccum,
DatabaseContextEvalState -> DirtyFlag
dbc_dirty :: DirtyFlag
}
data DatabaseContextEvalEnv = DatabaseContextEvalEnv
{ DatabaseContextEvalEnv -> TransactionId
dce_transId :: TransactionId,
DatabaseContextEvalEnv -> TransactionGraph
dce_graph :: TransactionGraph
}
mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv
mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv
mkDatabaseContextEvalEnv = TransactionId -> TransactionGraph -> DatabaseContextEvalEnv
DatabaseContextEvalEnv
type DatabaseContextEvalMonad a = RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity) a
runDatabaseContextEvalMonad :: DatabaseContext -> DatabaseContextEvalEnv -> DatabaseContextEvalMonad () -> Either RelationalError DatabaseContextEvalState
runDatabaseContextEvalMonad :: DatabaseContext
-> DatabaseContextEvalEnv
-> DatabaseContextEvalMonad ()
-> Either RelationalError DatabaseContextEvalState
runDatabaseContextEvalMonad DatabaseContext
ctx DatabaseContextEvalEnv
env DatabaseContextEvalMonad ()
m = Identity (Either RelationalError DatabaseContextEvalState)
-> Either RelationalError DatabaseContextEvalState
forall a. Identity a -> a
runIdentity (ExceptT RelationalError Identity DatabaseContextEvalState
-> Identity (Either RelationalError DatabaseContextEvalState)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ((DatabaseContextEvalState, ()) -> DatabaseContextEvalState
forall a b. (a, b) -> a
fst ((DatabaseContextEvalState, ()) -> DatabaseContextEvalState)
-> ExceptT RelationalError Identity (DatabaseContextEvalState, ())
-> ExceptT RelationalError Identity DatabaseContextEvalState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatabaseContextEvalMonad ()
-> DatabaseContextEvalEnv
-> DatabaseContextEvalState
-> ExceptT RelationalError Identity (DatabaseContextEvalState, ())
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (s, w)
execRWST DatabaseContextEvalMonad ()
m DatabaseContextEvalEnv
env DatabaseContextEvalState
freshEnv))
where
freshEnv :: DatabaseContextEvalState
freshEnv = DatabaseContext -> DatabaseContextEvalState
mkDatabaseContextEvalState DatabaseContext
ctx
dbcTransId :: DatabaseContextEvalMonad TransactionId
dbcTransId :: DatabaseContextEvalMonad TransactionId
dbcTransId = DatabaseContextEvalEnv -> TransactionId
dce_transId (DatabaseContextEvalEnv -> TransactionId)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContextEvalEnv
-> DatabaseContextEvalMonad TransactionId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContextEvalEnv
forall r (m :: * -> *). MonadReader r m => m r
RWS.ask
dbcGraph :: DatabaseContextEvalMonad TransactionGraph
dbcGraph :: DatabaseContextEvalMonad TransactionGraph
dbcGraph = DatabaseContextEvalEnv -> TransactionGraph
dce_graph (DatabaseContextEvalEnv -> TransactionGraph)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContextEvalEnv
-> DatabaseContextEvalMonad TransactionGraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContextEvalEnv
forall r (m :: * -> *). MonadReader r m => m r
RWS.ask
dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv
dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv
dbcRelationalExprEnv =
DatabaseContext -> TransactionGraph -> RelationalExprEnv
mkRelationalExprEnv (DatabaseContext -> TransactionGraph -> RelationalExprEnv)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(TransactionGraph -> RelationalExprEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(TransactionGraph -> RelationalExprEnv)
-> DatabaseContextEvalMonad TransactionGraph
-> DatabaseContextEvalMonad RelationalExprEnv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DatabaseContextEvalMonad TransactionGraph
dbcGraph
getStateContext :: DatabaseContextEvalMonad DatabaseContext
getStateContext :: RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext = (DatabaseContextEvalState -> DatabaseContext)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DatabaseContextEvalState -> DatabaseContext
dbc_context
putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext :: DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext DatabaseContext
ctx' = do
DatabaseContextEvalState
s <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContextEvalState
forall s (m :: * -> *). MonadState s m => m s
get
DatabaseContextEvalState -> DatabaseContextEvalMonad ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (DatabaseContextEvalState
s {dbc_context :: DatabaseContext
dbc_context = DatabaseContext
ctx', dbc_dirty :: DirtyFlag
dbc_dirty = DirtyFlag
True})
data GraphRefRelationalExprEnv =
GraphRefRelationalExprEnv {
GraphRefRelationalExprEnv -> Maybe DatabaseContext
gre_context :: Maybe DatabaseContext,
GraphRefRelationalExprEnv -> TransactionGraph
gre_graph :: TransactionGraph,
:: Maybe (Either RelationTuple Attributes)
}
type GraphRefRelationalExprM a = ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity) a
gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction
gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction
gfTransForId TransactionId
tid = do
TransactionGraph
graph <- GraphRefRelationalExprM TransactionGraph
gfGraph
ExceptT RelationalError Identity Transaction
-> GraphRefRelationalExprM Transaction
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Transaction
-> GraphRefRelationalExprM Transaction)
-> ExceptT RelationalError Identity Transaction
-> GraphRefRelationalExprM Transaction
forall a b. (a -> b) -> a -> b
$ Either RelationalError Transaction
-> ExceptT RelationalError Identity Transaction
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Transaction
-> ExceptT RelationalError Identity Transaction)
-> Either RelationalError Transaction
-> ExceptT RelationalError Identity Transaction
forall a b. (a -> b) -> a -> b
$ TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
tid TransactionGraph
graph
gfDatabaseContextForMarker :: GraphRefTransactionMarker -> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker :: GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker (TransactionMarker TransactionId
transId) = Transaction -> DatabaseContext
concreteDatabaseContext (Transaction -> DatabaseContext)
-> GraphRefRelationalExprM Transaction
-> GraphRefRelationalExprM DatabaseContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransactionId -> GraphRefRelationalExprM Transaction
gfTransForId TransactionId
transId
gfDatabaseContextForMarker GraphRefTransactionMarker
UncommittedContextMarker = do
Maybe DatabaseContext
mctx <- GraphRefRelationalExprEnv -> Maybe DatabaseContext
gre_context (GraphRefRelationalExprEnv -> Maybe DatabaseContext)
-> GraphRefRelationalExprM GraphRefRelationalExprEnv
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(Maybe DatabaseContext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv
case Maybe DatabaseContext
mctx of
Maybe DatabaseContext
Nothing -> RelationalError -> GraphRefRelationalExprM DatabaseContext
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
NoUncommittedContextInEvalError
Just DatabaseContext
ctx -> DatabaseContext -> GraphRefRelationalExprM DatabaseContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseContext
ctx
runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM :: GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
env GraphRefRelationalExprM a
m = Identity (Either RelationalError a) -> Either RelationalError a
forall a. Identity a -> a
runIdentity (ExceptT RelationalError Identity a
-> Identity (Either RelationalError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (GraphRefRelationalExprM a
-> GraphRefRelationalExprEnv -> ExceptT RelationalError Identity a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT GraphRefRelationalExprM a
m GraphRefRelationalExprEnv
env))
freshGraphRefRelationalExprEnv :: Maybe DatabaseContext -> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv :: Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv Maybe DatabaseContext
mctx TransactionGraph
graph = GraphRefRelationalExprEnv :: Maybe DatabaseContext
-> TransactionGraph
-> Maybe (Either RelationTuple Attributes)
-> GraphRefRelationalExprEnv
GraphRefRelationalExprEnv {
gre_context :: Maybe DatabaseContext
gre_context = Maybe DatabaseContext
mctx,
gre_graph :: TransactionGraph
gre_graph = TransactionGraph
graph,
gre_extra :: Maybe (Either RelationTuple Attributes)
gre_extra = Maybe (Either RelationTuple Attributes)
forall a. Maybe a
Nothing
}
gfGraph :: GraphRefRelationalExprM TransactionGraph
gfGraph :: GraphRefRelationalExprM TransactionGraph
gfGraph = (GraphRefRelationalExprEnv -> TransactionGraph)
-> GraphRefRelationalExprM TransactionGraph
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks GraphRefRelationalExprEnv -> TransactionGraph
gre_graph
envContext :: RelationalExprEnv -> DatabaseContext
envContext :: RelationalExprEnv -> DatabaseContext
envContext = RelationalExprEnv -> DatabaseContext
re_context
setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv
setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv
setEnvContext RelationalExprEnv
e DatabaseContext
ctx = RelationalExprEnv
e { re_context :: DatabaseContext
re_context = DatabaseContext
ctx }
setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar :: AttributeName
-> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar AttributeName
relVarName GraphRefRelationalExpr
relExpr = do
DatabaseContext
currentContext <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
GraphRefRelationalExpr
relExpr' <- GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
relExpr
let newRelVars :: Map AttributeName GraphRefRelationalExpr
newRelVars = AttributeName
-> GraphRefRelationalExpr
-> Map AttributeName GraphRefRelationalExpr
-> Map AttributeName GraphRefRelationalExpr
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AttributeName
relVarName GraphRefRelationalExpr
relExpr' (Map AttributeName GraphRefRelationalExpr
-> Map AttributeName GraphRefRelationalExpr)
-> Map AttributeName GraphRefRelationalExpr
-> Map AttributeName GraphRefRelationalExpr
forall a b. (a -> b) -> a -> b
$ DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables DatabaseContext
currentContext
potentialContext :: DatabaseContext
potentialContext = DatabaseContext
currentContext { relationVariables :: Map AttributeName GraphRefRelationalExpr
relationVariables = Map AttributeName GraphRefRelationalExpr
newRelVars }
if AttributeName
-> Map AttributeName GraphRefRelationalExpr
-> Maybe GraphRefRelationalExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
relVarName (DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables DatabaseContext
currentContext) Maybe GraphRefRelationalExpr
-> Maybe GraphRefRelationalExpr -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== GraphRefRelationalExpr -> Maybe GraphRefRelationalExpr
forall a. a -> Maybe a
Just GraphRefRelationalExpr
relExpr then
() -> DatabaseContextEvalMonad ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else do
TransactionGraph
graph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
TransactionId
tid <- DatabaseContextEvalMonad TransactionId
dbcTransId
case DatabaseContext
-> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints DatabaseContext
potentialContext TransactionId
tid TransactionGraph
graph of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right ()
_ -> DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext DatabaseContext
potentialContext
deleteRelVar :: RelVarName -> DatabaseContextEvalMonad ()
deleteRelVar :: AttributeName -> DatabaseContextEvalMonad ()
deleteRelVar AttributeName
relVarName = do
DatabaseContext
currContext <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
let relVars :: Map AttributeName GraphRefRelationalExpr
relVars = DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables DatabaseContext
currContext
if AttributeName
-> Map AttributeName GraphRefRelationalExpr -> DirtyFlag
forall k a. Ord k => k -> Map k a -> DirtyFlag
M.notMember AttributeName
relVarName Map AttributeName GraphRefRelationalExpr
relVars then
() -> DatabaseContextEvalMonad ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else do
let newRelVars :: Map AttributeName GraphRefRelationalExpr
newRelVars = AttributeName
-> Map AttributeName GraphRefRelationalExpr
-> Map AttributeName GraphRefRelationalExpr
forall k a. Ord k => k -> Map k a -> Map k a
M.delete AttributeName
relVarName Map AttributeName GraphRefRelationalExpr
relVars
newContext :: DatabaseContext
newContext = DatabaseContext
currContext { relationVariables :: Map AttributeName GraphRefRelationalExpr
relationVariables = Map AttributeName GraphRefRelationalExpr
newRelVars }
TransactionGraph
graph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
TransactionId
tid <- DatabaseContextEvalMonad TransactionId
dbcTransId
case DatabaseContext
-> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints DatabaseContext
newContext TransactionId
tid TransactionGraph
graph of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right ()
_ ->
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext DatabaseContext
newContext
evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
evalGraphRefDatabaseContextExpr GraphRefDatabaseContextExpr
NoOperation = () -> DatabaseContextEvalMonad ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
evalGraphRefDatabaseContextExpr (Define AttributeName
relVarName [AttributeExprBase GraphRefTransactionMarker]
attrExprs) = do
DatabaseContext
context <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
Map AttributeName GraphRefRelationalExpr
relvars <- (DatabaseContext -> Map AttributeName GraphRefRelationalExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(Map AttributeName GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
TypeConstructorMapping
tConss <- (DatabaseContext -> TypeConstructorMapping)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
TypeConstructorMapping
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DatabaseContext -> TypeConstructorMapping
typeConstructorMapping RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
TransactionGraph
graph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
let eAttrs :: Either RelationalError [Attribute]
eAttrs = GraphRefRelationalExprEnv
-> GraphRefRelationalExprM [Attribute]
-> Either RelationalError [Attribute]
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv ((AttributeExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute)
-> [AttributeExprBase GraphRefTransactionMarker]
-> GraphRefRelationalExprM [Attribute]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AttributeExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
evalGraphRefAttrExpr [AttributeExprBase GraphRefTransactionMarker]
attrExprs)
gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (DatabaseContext -> Maybe DatabaseContext
forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
case Either RelationalError [Attribute]
eAttrs of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right [Attribute]
attrsList -> do
ExceptT RelationalError Identity () -> DatabaseContextEvalMonad ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity ()
-> DatabaseContextEvalMonad ())
-> ExceptT RelationalError Identity ()
-> DatabaseContextEvalMonad ()
forall a b. (a -> b) -> a -> b
$ Either RelationalError () -> ExceptT RelationalError Identity ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError () -> ExceptT RelationalError Identity ())
-> Either RelationalError () -> ExceptT RelationalError Identity ()
forall a b. (a -> b) -> a -> b
$ TypeConstructorMapping -> Attributes -> Either RelationalError ()
validateAttributes TypeConstructorMapping
tConss ([Attribute] -> Attributes
A.attributesFromList [Attribute]
attrsList)
case AttributeName
-> Map AttributeName GraphRefRelationalExpr -> DirtyFlag
forall k a. Ord k => k -> Map k a -> DirtyFlag
M.member AttributeName
relVarName Map AttributeName GraphRefRelationalExpr
relvars of
DirtyFlag
True -> RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
RelVarAlreadyDefinedError AttributeName
relVarName)
DirtyFlag
False -> AttributeName
-> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar AttributeName
relVarName (Relation -> GraphRefRelationalExpr
forall a. Relation -> RelationalExprBase a
ExistingRelation Relation
emptyRelation)
where
attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [Attribute]
attrsList
emptyRelation :: Relation
emptyRelation = Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs RelationTupleSet
emptyTupleSet
evalGraphRefDatabaseContextExpr (Undefine AttributeName
relVarName) = AttributeName -> DatabaseContextEvalMonad ()
deleteRelVar AttributeName
relVarName
evalGraphRefDatabaseContextExpr (Assign AttributeName
relVarName GraphRefRelationalExpr
expr) = do
TransactionGraph
graph <- RelationalExprEnv -> TransactionGraph
re_graph (RelationalExprEnv -> TransactionGraph)
-> DatabaseContextEvalMonad RelationalExprEnv
-> DatabaseContextEvalMonad TransactionGraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatabaseContextEvalMonad RelationalExprEnv
dbcRelationalExprEnv
DatabaseContext
context <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
let existingRelVar :: Maybe GraphRefRelationalExpr
existingRelVar = AttributeName
-> Map AttributeName GraphRefRelationalExpr
-> Maybe GraphRefRelationalExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
relVarName (DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables DatabaseContext
context)
reEnv :: GraphRefRelationalExprEnv
reEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (DatabaseContext -> Maybe DatabaseContext
forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
eNewExprType :: Either RelationalError Relation
eNewExprType = GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
reEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
expr)
case Maybe GraphRefRelationalExpr
existingRelVar of
Maybe GraphRefRelationalExpr
Nothing -> do
case GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
reEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
expr) of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right Relation
reltype -> do
ExceptT RelationalError Identity () -> DatabaseContextEvalMonad ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity ()
-> DatabaseContextEvalMonad ())
-> ExceptT RelationalError Identity ()
-> DatabaseContextEvalMonad ()
forall a b. (a -> b) -> a -> b
$ Either RelationalError () -> ExceptT RelationalError Identity ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError () -> ExceptT RelationalError Identity ())
-> Either RelationalError () -> ExceptT RelationalError Identity ()
forall a b. (a -> b) -> a -> b
$ TypeConstructorMapping -> Attributes -> Either RelationalError ()
validateAttributes (DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
context) (Relation -> Attributes
attributes Relation
reltype)
AttributeName
-> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar AttributeName
relVarName GraphRefRelationalExpr
expr
Just GraphRefRelationalExpr
existingRel -> do
let eExpectedType :: Either RelationalError Relation
eExpectedType = GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
reEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
existingRel)
case Either RelationalError Relation
eExpectedType of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right Relation
expectedType ->
case Either RelationalError Relation
eNewExprType of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right Relation
newExprType -> do
if Relation
newExprType Relation -> Relation -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== Relation
expectedType then do
ExceptT RelationalError Identity () -> DatabaseContextEvalMonad ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity ()
-> DatabaseContextEvalMonad ())
-> ExceptT RelationalError Identity ()
-> DatabaseContextEvalMonad ()
forall a b. (a -> b) -> a -> b
$ Either RelationalError () -> ExceptT RelationalError Identity ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError () -> ExceptT RelationalError Identity ())
-> Either RelationalError () -> ExceptT RelationalError Identity ()
forall a b. (a -> b) -> a -> b
$ TypeConstructorMapping -> Attributes -> Either RelationalError ()
validateAttributes (DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
context) (Relation -> Attributes
attributes Relation
newExprType)
AttributeName
-> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar AttributeName
relVarName GraphRefRelationalExpr
expr
else
RelationalError -> DatabaseContextEvalMonad ()
dbErr (Attributes -> Attributes -> RelationalError
RelationTypeMismatchError (Relation -> Attributes
attributes Relation
expectedType) (Relation -> Attributes
attributes Relation
newExprType))
evalGraphRefDatabaseContextExpr (Insert AttributeName
relVarName GraphRefRelationalExpr
relExpr) = do
GraphRefRelationalExpr
gfExpr <- AttributeName -> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (m :: * -> *).
DatabaseContextM m =>
AttributeName -> m GraphRefRelationalExpr
relVarByName AttributeName
relVarName
let optExpr :: GraphRefRelationalExpr
optExpr = GraphRefRelationalExpr -> GraphRefRelationalExpr
applyUnionCollapse (GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union
GraphRefRelationalExpr
relExpr
GraphRefRelationalExpr
gfExpr)
GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
evalGraphRefDatabaseContextExpr (AttributeName
-> GraphRefRelationalExpr -> GraphRefDatabaseContextExpr
forall a.
AttributeName -> RelationalExprBase a -> DatabaseContextExprBase a
Assign AttributeName
relVarName GraphRefRelationalExpr
optExpr)
evalGraphRefDatabaseContextExpr (Delete AttributeName
relVarName RestrictionPredicateExprBase GraphRefTransactionMarker
predicate) = do
GraphRefRelationalExpr
gfExpr <- AttributeName -> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (m :: * -> *).
DatabaseContextM m =>
AttributeName -> m GraphRefRelationalExpr
relVarByName AttributeName
relVarName
let optExpr :: GraphRefRelationalExpr
optExpr = GraphRefRelationalExpr -> GraphRefRelationalExpr
applyRestrictionCollapse (RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker
forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
predicate) GraphRefRelationalExpr
gfExpr)
AttributeName
-> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar AttributeName
relVarName GraphRefRelationalExpr
optExpr
evalGraphRefDatabaseContextExpr (Update AttributeName
relVarName AttributeNameAtomExprMap
atomExprMap RestrictionPredicateExprBase GraphRefTransactionMarker
pred') = do
GraphRefRelationalExpr
rvExpr <- AttributeName -> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (m :: * -> *).
DatabaseContextM m =>
AttributeName -> m GraphRefRelationalExpr
relVarByName AttributeName
relVarName
TransactionGraph
graph <- RelationalExprEnv -> TransactionGraph
re_graph (RelationalExprEnv -> TransactionGraph)
-> DatabaseContextEvalMonad RelationalExprEnv
-> DatabaseContextEvalMonad TransactionGraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatabaseContextEvalMonad RelationalExprEnv
dbcRelationalExprEnv
DatabaseContext
context <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
let reEnv :: GraphRefRelationalExprEnv
reEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (DatabaseContext -> Maybe DatabaseContext
forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
eExprType :: Either RelationalError Relation
eExprType = GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
reEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
rvExpr)
Relation
exprType' <- case Either RelationalError Relation
eExprType of
Left RelationalError
err -> RelationalError
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
Relation
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right Relation
t -> Relation
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
Relation
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
t
let unrestrictedPortion :: GraphRefRelationalExpr
unrestrictedPortion = RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker
forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
pred') GraphRefRelationalExpr
rvExpr
tmpAttr :: AttributeName -> AttributeName
tmpAttr = Int -> AttributeName -> AttributeName
tmpAttrC Int
1
tmpAttrC :: Int -> AttributeName -> AttributeName
tmpAttrC :: Int -> AttributeName -> AttributeName
tmpAttrC Int
c AttributeName
attr =
let tmpAttrName :: AttributeName
tmpAttrName = AttributeName
"_tmp_" AttributeName -> AttributeName -> AttributeName
forall a. Semigroup a => a -> a -> a
<> [Char] -> AttributeName
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
c) AttributeName -> AttributeName -> AttributeName
forall a. Semigroup a => a -> a -> a
<> AttributeName
attr in
if AttributeName
tmpAttrName AttributeName -> Set AttributeName -> DirtyFlag
forall a. Ord a => a -> Set a -> DirtyFlag
`S.member` Attributes -> Set AttributeName
A.attributeNameSet (Relation -> Attributes
attributes Relation
exprType') then
Int -> AttributeName -> AttributeName
tmpAttrC (Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) AttributeName
attr
else
AttributeName
tmpAttrName
updateAttr :: AttributeName
-> AtomExprBase a -> RelationalExprBase a -> RelationalExprBase a
updateAttr AttributeName
nam AtomExprBase a
atomExpr = ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Extend (AttributeName -> AtomExprBase a -> ExtendTupleExprBase a
forall a. AttributeName -> AtomExprBase a -> ExtendTupleExprBase a
AttributeExtendTupleExpr (AttributeName -> AttributeName
tmpAttr AttributeName
nam) AtomExprBase a
atomExpr)
projectAndRename :: AttributeName -> RelationalExprBase a -> RelationalExprBase a
projectAndRename AttributeName
attr RelationalExprBase a
expr = AttributeName
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
forall a.
AttributeName
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
Rename (AttributeName -> AttributeName
tmpAttr AttributeName
attr) AttributeName
attr (AttributeNamesBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
AttributeNamesBase a
-> RelationalExprBase a -> RelationalExprBase a
Project (Set AttributeName -> AttributeNamesBase a
forall a. Set AttributeName -> AttributeNamesBase a
InvertedAttributeNames (AttributeName -> Set AttributeName
forall a. a -> Set a
S.singleton AttributeName
attr)) RelationalExprBase a
expr)
restrictedPortion :: GraphRefRelationalExpr
restrictedPortion = RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict RestrictionPredicateExprBase GraphRefTransactionMarker
pred' GraphRefRelationalExpr
rvExpr
updated :: GraphRefRelationalExpr
updated = ((AttributeName, AtomExpr)
-> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> GraphRefRelationalExpr
-> [(AttributeName, AtomExpr)]
-> GraphRefRelationalExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(AttributeName
oldname, AtomExpr
atomExpr) GraphRefRelationalExpr
accum ->
let procAtomExpr :: GraphRefAtomExpr
procAtomExpr = GraphRefTransactionMarker
-> ProcessExprM GraphRefAtomExpr -> GraphRefAtomExpr
forall a. GraphRefTransactionMarker -> ProcessExprM a -> a
runProcessExprM GraphRefTransactionMarker
UncommittedContextMarker (AtomExpr -> ProcessExprM GraphRefAtomExpr
processAtomExpr AtomExpr
atomExpr) in
AttributeName
-> GraphRefAtomExpr
-> GraphRefRelationalExpr
-> GraphRefRelationalExpr
forall a.
AttributeName
-> AtomExprBase a -> RelationalExprBase a -> RelationalExprBase a
updateAttr AttributeName
oldname GraphRefAtomExpr
procAtomExpr GraphRefRelationalExpr
accum
) GraphRefRelationalExpr
restrictedPortion (AttributeNameAtomExprMap -> [(AttributeName, AtomExpr)]
forall k a. Map k a -> [(k, a)]
M.toList AttributeNameAtomExprMap
atomExprMap)
updatedPortion :: GraphRefRelationalExpr
updatedPortion = (AttributeName -> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> GraphRefRelationalExpr
-> [AttributeName]
-> GraphRefRelationalExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AttributeName -> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
AttributeName -> RelationalExprBase a -> RelationalExprBase a
projectAndRename GraphRefRelationalExpr
updated (AttributeNameAtomExprMap -> [AttributeName]
forall k a. Map k a -> [k]
M.keys AttributeNameAtomExprMap
atomExprMap)
AttributeName
-> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar AttributeName
relVarName (GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union GraphRefRelationalExpr
unrestrictedPortion GraphRefRelationalExpr
updatedPortion)
evalGraphRefDatabaseContextExpr (AddInclusionDependency AttributeName
newDepName InclusionDependency
newDep) = do
DatabaseContext
currContext <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
TransactionId
transId <- DatabaseContextEvalMonad TransactionId
dbcTransId
TransactionGraph
graph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
let currDeps :: InclusionDependencies
currDeps = DatabaseContext -> InclusionDependencies
inclusionDependencies DatabaseContext
currContext
newDeps :: InclusionDependencies
newDeps = AttributeName
-> InclusionDependency
-> InclusionDependencies
-> InclusionDependencies
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AttributeName
newDepName InclusionDependency
newDep InclusionDependencies
currDeps
if AttributeName -> InclusionDependencies -> DirtyFlag
forall k a. Ord k => k -> Map k a -> DirtyFlag
M.member AttributeName
newDepName InclusionDependencies
currDeps then
RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
InclusionDependencyNameInUseError AttributeName
newDepName)
else do
let potentialContext :: DatabaseContext
potentialContext = DatabaseContext
currContext { inclusionDependencies :: InclusionDependencies
inclusionDependencies = InclusionDependencies
newDeps }
case DatabaseContext
-> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints DatabaseContext
potentialContext TransactionId
transId TransactionGraph
graph of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right ()
_ ->
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext DatabaseContext
potentialContext
evalGraphRefDatabaseContextExpr (RemoveInclusionDependency AttributeName
depName) = do
DatabaseContext
currContext <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
let currDeps :: InclusionDependencies
currDeps = DatabaseContext -> InclusionDependencies
inclusionDependencies DatabaseContext
currContext
newDeps :: InclusionDependencies
newDeps = AttributeName -> InclusionDependencies -> InclusionDependencies
forall k a. Ord k => k -> Map k a -> Map k a
M.delete AttributeName
depName InclusionDependencies
currDeps
if AttributeName -> InclusionDependencies -> DirtyFlag
forall k a. Ord k => k -> Map k a -> DirtyFlag
M.notMember AttributeName
depName InclusionDependencies
currDeps then
RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
InclusionDependencyNameNotInUseError AttributeName
depName)
else
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext (DatabaseContext -> DatabaseContextEvalMonad ())
-> DatabaseContext -> DatabaseContextEvalMonad ()
forall a b. (a -> b) -> a -> b
$ DatabaseContext
currContext {inclusionDependencies :: InclusionDependencies
inclusionDependencies = InclusionDependencies
newDeps }
evalGraphRefDatabaseContextExpr (AddNotification AttributeName
notName RelationalExpr
triggerExpr RelationalExpr
resultOldExpr RelationalExpr
resultNewExpr) = do
DatabaseContext
currentContext <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
let nots :: Notifications
nots = DatabaseContext -> Notifications
notifications DatabaseContext
currentContext
if AttributeName -> Notifications -> DirtyFlag
forall k a. Ord k => k -> Map k a -> DirtyFlag
M.member AttributeName
notName Notifications
nots then
RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
NotificationNameInUseError AttributeName
notName)
else do
let newNotifications :: Notifications
newNotifications = AttributeName -> Notification -> Notifications -> Notifications
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AttributeName
notName Notification
newNotification Notifications
nots
newNotification :: Notification
newNotification = Notification :: RelationalExpr -> RelationalExpr -> RelationalExpr -> Notification
Notification { changeExpr :: RelationalExpr
changeExpr = RelationalExpr
triggerExpr,
reportOldExpr :: RelationalExpr
reportOldExpr = RelationalExpr
resultOldExpr,
reportNewExpr :: RelationalExpr
reportNewExpr = RelationalExpr
resultNewExpr}
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext (DatabaseContext -> DatabaseContextEvalMonad ())
-> DatabaseContext -> DatabaseContextEvalMonad ()
forall a b. (a -> b) -> a -> b
$ DatabaseContext
currentContext { notifications :: Notifications
notifications = Notifications
newNotifications }
evalGraphRefDatabaseContextExpr (RemoveNotification AttributeName
notName) = do
DatabaseContext
currentContext <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
let nots :: Notifications
nots = DatabaseContext -> Notifications
notifications DatabaseContext
currentContext
if AttributeName -> Notifications -> DirtyFlag
forall k a. Ord k => k -> Map k a -> DirtyFlag
M.notMember AttributeName
notName Notifications
nots then
RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
NotificationNameNotInUseError AttributeName
notName)
else do
let newNotifications :: Notifications
newNotifications = AttributeName -> Notifications -> Notifications
forall k a. Ord k => k -> Map k a -> Map k a
M.delete AttributeName
notName Notifications
nots
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext (DatabaseContext -> DatabaseContextEvalMonad ())
-> DatabaseContext -> DatabaseContextEvalMonad ()
forall a b. (a -> b) -> a -> b
$ DatabaseContext
currentContext { notifications :: Notifications
notifications = Notifications
newNotifications }
evalGraphRefDatabaseContextExpr (AddTypeConstructor TypeConstructorDef
tConsDef [DataConstructorDef]
dConsDefList) = do
DatabaseContext
currentContext <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
let oldTypes :: TypeConstructorMapping
oldTypes = DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
currentContext
tConsName :: AttributeName
tConsName = TypeConstructorDef -> AttributeName
TCD.name TypeConstructorDef
tConsDef
case TypeConstructorDef
-> [DataConstructorDef]
-> TypeConstructorMapping
-> Either RelationalError ()
validateTypeConstructorDef TypeConstructorDef
tConsDef [DataConstructorDef]
dConsDefList TypeConstructorMapping
oldTypes of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right () | AttributeName -> DirtyFlag
T.null AttributeName
tConsName DirtyFlag -> DirtyFlag -> DirtyFlag
|| DirtyFlag -> DirtyFlag
not (Char -> DirtyFlag
isUpper (AttributeName -> Char
T.head AttributeName
tConsName)) -> RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
InvalidAtomTypeName AttributeName
tConsName)
| Maybe (TypeConstructorDef, [DataConstructorDef]) -> DirtyFlag
forall a. Maybe a -> DirtyFlag
isJust (AttributeName
-> TypeConstructorMapping
-> Maybe (TypeConstructorDef, [DataConstructorDef])
findTypeConstructor AttributeName
tConsName TypeConstructorMapping
oldTypes) -> RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
AtomTypeNameInUseError AttributeName
tConsName)
| DirtyFlag
otherwise -> do
let newTypes :: TypeConstructorMapping
newTypes = TypeConstructorMapping
oldTypes TypeConstructorMapping
-> TypeConstructorMapping -> TypeConstructorMapping
forall a. [a] -> [a] -> [a]
++ [(TypeConstructorDef
tConsDef, [DataConstructorDef]
dConsDefList)]
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext (DatabaseContext -> DatabaseContextEvalMonad ())
-> DatabaseContext -> DatabaseContextEvalMonad ()
forall a b. (a -> b) -> a -> b
$ DatabaseContext
currentContext { typeConstructorMapping :: TypeConstructorMapping
typeConstructorMapping = TypeConstructorMapping
newTypes }
evalGraphRefDatabaseContextExpr (RemoveTypeConstructor AttributeName
tConsName) = do
DatabaseContext
currentContext <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
let oldTypes :: TypeConstructorMapping
oldTypes = DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
currentContext
if Maybe (TypeConstructorDef, [DataConstructorDef]) -> DirtyFlag
forall a. Maybe a -> DirtyFlag
isNothing (AttributeName
-> TypeConstructorMapping
-> Maybe (TypeConstructorDef, [DataConstructorDef])
findTypeConstructor AttributeName
tConsName TypeConstructorMapping
oldTypes) then
RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
AtomTypeNameNotInUseError AttributeName
tConsName)
else do
let newTypes :: TypeConstructorMapping
newTypes = ((TypeConstructorDef, [DataConstructorDef]) -> DirtyFlag)
-> TypeConstructorMapping -> TypeConstructorMapping
forall a. (a -> DirtyFlag) -> [a] -> [a]
filter (\(TypeConstructorDef
tCons, [DataConstructorDef]
_) -> TypeConstructorDef -> AttributeName
TCD.name TypeConstructorDef
tCons AttributeName -> AttributeName -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= AttributeName
tConsName) TypeConstructorMapping
oldTypes
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext (DatabaseContext -> DatabaseContextEvalMonad ())
-> DatabaseContext -> DatabaseContextEvalMonad ()
forall a b. (a -> b) -> a -> b
$ DatabaseContext
currentContext { typeConstructorMapping :: TypeConstructorMapping
typeConstructorMapping = TypeConstructorMapping
newTypes }
evalGraphRefDatabaseContextExpr (MultipleExpr [GraphRefDatabaseContextExpr]
exprs) =
(GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ())
-> [GraphRefDatabaseContextExpr] -> DatabaseContextEvalMonad ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
evalGraphRefDatabaseContextExpr [GraphRefDatabaseContextExpr]
exprs
evalGraphRefDatabaseContextExpr (RemoveAtomFunction AttributeName
funcName') = do
DatabaseContext
currentContext <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
let atomFuncs :: AtomFunctions
atomFuncs = DatabaseContext -> AtomFunctions
atomFunctions DatabaseContext
currentContext
case AttributeName
-> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName AttributeName
funcName' AtomFunctions
atomFuncs of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right AtomFunction
realFunc ->
if AtomFunction -> DirtyFlag
isScriptedAtomFunction AtomFunction
realFunc then do
let updatedFuncs :: AtomFunctions
updatedFuncs = AtomFunction -> AtomFunctions -> AtomFunctions
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.delete AtomFunction
realFunc AtomFunctions
atomFuncs
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext (DatabaseContext
currentContext {atomFunctions :: AtomFunctions
atomFunctions = AtomFunctions
updatedFuncs })
else
RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
PrecompiledFunctionRemoveError AttributeName
funcName')
evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction AttributeName
funcName') = do
DatabaseContext
context <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
let dbcFuncs :: DatabaseContextFunctions
dbcFuncs = DatabaseContext -> DatabaseContextFunctions
dbcFunctions DatabaseContext
context
case AttributeName
-> DatabaseContextFunctions
-> Either RelationalError DatabaseContextFunction
databaseContextFunctionForName AttributeName
funcName' DatabaseContextFunctions
dbcFuncs of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right DatabaseContextFunction
realFunc ->
if DatabaseContextFunction -> DirtyFlag
isScriptedDatabaseContextFunction DatabaseContextFunction
realFunc then do
let updatedFuncs :: DatabaseContextFunctions
updatedFuncs = DatabaseContextFunction
-> DatabaseContextFunctions -> DatabaseContextFunctions
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.delete DatabaseContextFunction
realFunc DatabaseContextFunctions
dbcFuncs
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext (DatabaseContext
context { dbcFunctions :: DatabaseContextFunctions
dbcFunctions = DatabaseContextFunctions
updatedFuncs })
else
RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
PrecompiledFunctionRemoveError AttributeName
funcName')
evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction AttributeName
funcName' [GraphRefAtomExpr]
atomArgExprs) = do
DatabaseContext
context <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
TransactionGraph
graph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
let eAtomTypes :: Either RelationalError [AtomType]
eAtomTypes = (GraphRefAtomExpr -> Either RelationalError AtomType)
-> [GraphRefAtomExpr] -> Either RelationalError [AtomType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GraphRefRelationalExprEnv
-> GraphRefRelationalExprM AtomType
-> Either RelationalError AtomType
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExprM AtomType
-> Either RelationalError AtomType)
-> (GraphRefAtomExpr -> GraphRefRelationalExprM AtomType)
-> GraphRefAtomExpr
-> Either RelationalError AtomType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
emptyAttributes) [GraphRefAtomExpr]
atomArgExprs
eFunc :: Either RelationalError DatabaseContextFunction
eFunc = AttributeName
-> DatabaseContextFunctions
-> Either RelationalError DatabaseContextFunction
databaseContextFunctionForName AttributeName
funcName' (DatabaseContext -> DatabaseContextFunctions
dbcFunctions DatabaseContext
context)
gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (DatabaseContext -> Maybe DatabaseContext
forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
case Either RelationalError DatabaseContextFunction
eFunc of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right DatabaseContextFunction
func -> do
let expectedArgCount :: Int
expectedArgCount = [AtomType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DatabaseContextFunction -> [AtomType]
forall a. Function a -> [AtomType]
funcType DatabaseContextFunction
func)
actualArgCount :: Int
actualArgCount = [GraphRefAtomExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GraphRefAtomExpr]
atomArgExprs
if Int
expectedArgCount Int -> Int -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= Int
actualArgCount then
RelationalError -> DatabaseContextEvalMonad ()
dbErr (Int -> Int -> RelationalError
FunctionArgumentCountMismatchError Int
expectedArgCount Int
actualArgCount)
else
case Either RelationalError [AtomType]
eAtomTypes of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right [AtomType]
atomTypes -> do
let mValidTypes :: [Maybe RelationalError]
mValidTypes = (AtomType -> AtomType -> Maybe RelationalError)
-> [AtomType] -> [AtomType] -> [Maybe RelationalError]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ AtomType
expType AtomType
actType
-> case AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expType AtomType
actType of
Left RelationalError
err -> RelationalError -> Maybe RelationalError
forall a. a -> Maybe a
Just RelationalError
err
Right AtomType
_ -> Maybe RelationalError
forall a. Maybe a
Nothing)
(DatabaseContextFunction -> [AtomType]
forall a. Function a -> [AtomType]
funcType DatabaseContextFunction
func) [AtomType]
atomTypes
typeErrors :: [RelationalError]
typeErrors = [Maybe RelationalError] -> [RelationalError]
forall a. [Maybe a] -> [a]
catMaybes [Maybe RelationalError]
mValidTypes
eAtomArgs :: [Either RelationalError Atom]
eAtomArgs = (GraphRefAtomExpr -> Either RelationalError Atom)
-> [GraphRefAtomExpr] -> [Either RelationalError Atom]
forall a b. (a -> b) -> [a] -> [b]
map (GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Atom -> Either RelationalError Atom
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExprM Atom -> Either RelationalError Atom)
-> (GraphRefAtomExpr -> GraphRefRelationalExprM Atom)
-> GraphRefAtomExpr
-> Either RelationalError Atom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
emptyTuple) [GraphRefAtomExpr]
atomArgExprs
if [RelationalError] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Either RelationalError Atom] -> [RelationalError]
forall a b. [Either a b] -> [a]
lefts [Either RelationalError Atom]
eAtomArgs) Int -> Int -> DirtyFlag
forall a. Ord a => a -> a -> DirtyFlag
> Int
1 then
RelationalError -> DatabaseContextEvalMonad ()
dbErr ([RelationalError] -> RelationalError
someErrors ([Either RelationalError Atom] -> [RelationalError]
forall a b. [Either a b] -> [a]
lefts [Either RelationalError Atom]
eAtomArgs))
else if DirtyFlag -> DirtyFlag
not ([RelationalError] -> DirtyFlag
forall (t :: * -> *) a. Foldable t => t a -> DirtyFlag
null [RelationalError]
typeErrors) then
RelationalError -> DatabaseContextEvalMonad ()
dbErr ([RelationalError] -> RelationalError
someErrors [RelationalError]
typeErrors)
else
case DatabaseContextFunction
-> [Atom]
-> DatabaseContext
-> Either RelationalError DatabaseContext
evalDatabaseContextFunction DatabaseContextFunction
func ([Either RelationalError Atom] -> [Atom]
forall a b. [Either a b] -> [b]
rights [Either RelationalError Atom]
eAtomArgs) DatabaseContext
context of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right DatabaseContext
newContext -> DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext DatabaseContext
newContext
evalGraphRefDatabaseContextExpr (AddRegisteredQuery AttributeName
regName RelationalExpr
regExpr) = do
DatabaseContext
context <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
TransactionGraph
tgraph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
TransactionId
tid <- DatabaseContextEvalMonad TransactionId
dbcTransId
case AttributeName
-> Map AttributeName RelationalExpr -> Maybe RelationalExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
regName (DatabaseContext -> Map AttributeName RelationalExpr
registeredQueries DatabaseContext
context) of
Just RelationalExpr
_ -> RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
RegisteredQueryNameInUseError AttributeName
regName)
Maybe RelationalExpr
Nothing -> do
let context' :: DatabaseContext
context' = DatabaseContext
context { registeredQueries :: Map AttributeName RelationalExpr
registeredQueries = AttributeName
-> RelationalExpr
-> Map AttributeName RelationalExpr
-> Map AttributeName RelationalExpr
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AttributeName
regName RelationalExpr
regExpr (DatabaseContext -> Map AttributeName RelationalExpr
registeredQueries DatabaseContext
context) }
case DatabaseContext
-> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints DatabaseContext
context' TransactionId
tid TransactionGraph
tgraph of
Left RelationalError
err -> RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err
Right ()
_ -> DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext DatabaseContext
context'
evalGraphRefDatabaseContextExpr (RemoveRegisteredQuery AttributeName
regName) = do
DatabaseContext
context <- RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
case AttributeName
-> Map AttributeName RelationalExpr -> Maybe RelationalExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
regName (DatabaseContext -> Map AttributeName RelationalExpr
registeredQueries DatabaseContext
context) of
Maybe RelationalExpr
Nothing -> RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
RegisteredQueryNameNotInUseError AttributeName
regName)
Just RelationalExpr
_ -> DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext (DatabaseContext
context { registeredQueries :: Map AttributeName RelationalExpr
registeredQueries = AttributeName
-> Map AttributeName RelationalExpr
-> Map AttributeName RelationalExpr
forall k a. Ord k => k -> Map k a -> Map k a
M.delete AttributeName
regName (DatabaseContext -> Map AttributeName RelationalExpr
registeredQueries DatabaseContext
context) })
data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv
{ DatabaseContextIOEvalEnv -> TransactionId
dbcio_transId :: TransactionId,
DatabaseContextIOEvalEnv -> TransactionGraph
dbcio_graph :: TransactionGraph,
DatabaseContextIOEvalEnv -> Maybe ScriptSession
dbcio_mScriptSession :: Maybe ScriptSession,
DatabaseContextIOEvalEnv -> Maybe [Char]
dbcio_mModulesDirectory :: Maybe FilePath
}
type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO a
runDatabaseContextIOEvalMonad :: DatabaseContextIOEvalEnv -> DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ()) -> IO (Either RelationalError DatabaseContextEvalState)
runDatabaseContextIOEvalMonad :: DatabaseContextIOEvalEnv
-> DatabaseContext
-> DatabaseContextIOEvalMonad (Either RelationalError ())
-> IO (Either RelationalError DatabaseContextEvalState)
runDatabaseContextIOEvalMonad DatabaseContextIOEvalEnv
env DatabaseContext
ctx DatabaseContextIOEvalMonad (Either RelationalError ())
m = do
(Either RelationalError (), DatabaseContextEvalState, ())
res <- DatabaseContextIOEvalMonad (Either RelationalError ())
-> DatabaseContextIOEvalEnv
-> DatabaseContextEvalState
-> IO (Either RelationalError (), DatabaseContextEvalState, ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST DatabaseContextIOEvalMonad (Either RelationalError ())
m DatabaseContextIOEvalEnv
env DatabaseContextEvalState
freshState
case (Either RelationalError (), DatabaseContextEvalState, ())
res of
(Left RelationalError
err,DatabaseContextEvalState
_,()
_) -> Either RelationalError DatabaseContextEvalState
-> IO (Either RelationalError DatabaseContextEvalState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError DatabaseContextEvalState
forall a b. a -> Either a b
Left RelationalError
err)
(Right (),DatabaseContextEvalState
s,()
_) -> Either RelationalError DatabaseContextEvalState
-> IO (Either RelationalError DatabaseContextEvalState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DatabaseContextEvalState
-> Either RelationalError DatabaseContextEvalState
forall a b. b -> Either a b
Right DatabaseContextEvalState
s)
where
freshState :: DatabaseContextEvalState
freshState = DatabaseContext -> DatabaseContextEvalState
mkDatabaseContextEvalState DatabaseContext
ctx
requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)
requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)
requireScriptSession = do
DatabaseContextIOEvalEnv
env <- RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
DatabaseContextIOEvalEnv
forall r (m :: * -> *). MonadReader r m => m r
RWS.ask
case DatabaseContextIOEvalEnv -> Maybe ScriptSession
dbcio_mScriptSession DatabaseContextIOEvalEnv
env of
Maybe ScriptSession
Nothing -> Either RelationalError ScriptSession
-> DatabaseContextIOEvalMonad
(Either RelationalError ScriptSession)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RelationalError ScriptSession
-> DatabaseContextIOEvalMonad
(Either RelationalError ScriptSession))
-> Either RelationalError ScriptSession
-> DatabaseContextIOEvalMonad
(Either RelationalError ScriptSession)
forall a b. (a -> b) -> a -> b
$ RelationalError -> Either RelationalError ScriptSession
forall a b. a -> Either a b
Left (RelationalError -> Either RelationalError ScriptSession)
-> RelationalError -> Either RelationalError ScriptSession
forall a b. (a -> b) -> a -> b
$ ScriptCompilationError -> RelationalError
ScriptError ScriptCompilationError
ScriptCompilationDisabledError
Just ScriptSession
ss -> Either RelationalError ScriptSession
-> DatabaseContextIOEvalMonad
(Either RelationalError ScriptSession)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptSession -> Either RelationalError ScriptSession
forall a b. b -> Either a b
Right ScriptSession
ss)
putDBCIOContext :: DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext :: DatabaseContext
-> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext DatabaseContext
ctx = do
(DatabaseContextEvalState -> DatabaseContextEvalState)
-> RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
RWS.modify (\DatabaseContextEvalState
dbstate -> DatabaseContextEvalState
dbstate { dbc_context :: DatabaseContext
dbc_context = DatabaseContext
ctx})
Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either RelationalError ()
forall a b. b -> Either a b
Right ())
getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext = DatabaseContextEvalState -> DatabaseContext
dbc_context (DatabaseContextEvalState -> DatabaseContext)
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
DatabaseContextEvalState
-> DatabaseContextIOEvalMonad DatabaseContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
DatabaseContextEvalState
forall s (m :: * -> *). MonadState s m => m s
RWS.get
getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv
getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv
getDBCIORelationalExprEnv = do
DatabaseContext
context <- DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext
DatabaseContext -> TransactionGraph -> RelationalExprEnv
mkRelationalExprEnv DatabaseContext
context (TransactionGraph -> RelationalExprEnv)
-> (DatabaseContextIOEvalEnv -> TransactionGraph)
-> DatabaseContextIOEvalEnv
-> RelationalExprEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatabaseContextIOEvalEnv -> TransactionGraph
dbcio_graph (DatabaseContextIOEvalEnv -> RelationalExprEnv)
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
DatabaseContextIOEvalEnv
-> DatabaseContextIOEvalMonad RelationalExprEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
DatabaseContextIOEvalEnv
forall r (m :: * -> *). MonadReader r m => m r
RWS.ask
evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())
#if !defined(PM36_HASKELL_SCRIPTING)
evalGraphRefDatabaseContextIOExpr AddAtomFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))
evalGraphRefDatabaseContextIOExpr AddDatabaseContextFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))
evalGraphRefDatabaseContextIOExpr LoadAtomFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))
evalGraphRefDatabaseContextIOExpr LoadDatabaseContextFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))
#else
evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr
-> DatabaseContextIOEvalMonad (Either RelationalError ())
evalGraphRefDatabaseContextIOExpr (AddAtomFunction AttributeName
funcName' [TypeConstructor]
funcType' AttributeName
script) = do
Either RelationalError ScriptSession
eScriptSession <- DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)
requireScriptSession
DatabaseContext
currentContext <- DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext
case Either RelationalError ScriptSession
eScriptSession of
Left RelationalError
err -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
err)
Right ScriptSession
scriptSession -> do
Either SomeException (Either RelationalError DatabaseContext)
res <- IO (Either SomeException (Either RelationalError DatabaseContext))
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either SomeException (Either RelationalError DatabaseContext))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException (Either RelationalError DatabaseContext))
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either SomeException (Either RelationalError DatabaseContext)))
-> IO
(Either SomeException (Either RelationalError DatabaseContext))
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either SomeException (Either RelationalError DatabaseContext))
forall a b. (a -> b) -> a -> b
$ IO (Either RelationalError DatabaseContext)
-> IO
(Either SomeException (Either RelationalError DatabaseContext))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Either RelationalError DatabaseContext)
-> IO
(Either SomeException (Either RelationalError DatabaseContext)))
-> IO (Either RelationalError DatabaseContext)
-> IO
(Either SomeException (Either RelationalError DatabaseContext))
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> Ghc (Either RelationalError DatabaseContext)
-> IO (Either RelationalError DatabaseContext)
forall a. Maybe [Char] -> Ghc a -> IO a
runGhc ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
libdir) (Ghc (Either RelationalError DatabaseContext)
-> IO (Either RelationalError DatabaseContext))
-> Ghc (Either RelationalError DatabaseContext)
-> IO (Either RelationalError DatabaseContext)
forall a b. (a -> b) -> a -> b
$ do
HscEnv -> Ghc ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (ScriptSession -> HscEnv
hscEnv ScriptSession
scriptSession)
let atomFuncs :: AtomFunctions
atomFuncs = DatabaseContext -> AtomFunctions
atomFunctions DatabaseContext
currentContext
case [TypeConstructor] -> Either RelationalError [TypeConstructor]
extractAtomFunctionType [TypeConstructor]
funcType' of
Left RelationalError
err -> Either RelationalError DatabaseContext
-> Ghc (Either RelationalError DatabaseContext)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError DatabaseContext
forall a b. a -> Either a b
Left RelationalError
err)
Right [TypeConstructor]
adjustedAtomTypeCons -> do
Either ScriptCompilationError AtomFunctionBodyType
eCompiledFunc <- Type
-> AttributeName
-> Ghc (Either ScriptCompilationError AtomFunctionBodyType)
forall a.
Type -> AttributeName -> Ghc (Either ScriptCompilationError a)
compileScript (ScriptSession -> Type
atomFunctionBodyType ScriptSession
scriptSession) AttributeName
script
Either RelationalError DatabaseContext
-> Ghc (Either RelationalError DatabaseContext)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RelationalError DatabaseContext
-> Ghc (Either RelationalError DatabaseContext))
-> Either RelationalError DatabaseContext
-> Ghc (Either RelationalError DatabaseContext)
forall a b. (a -> b) -> a -> b
$ case Either ScriptCompilationError AtomFunctionBodyType
eCompiledFunc of
Left ScriptCompilationError
err -> RelationalError -> Either RelationalError DatabaseContext
forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError ScriptCompilationError
err)
Right AtomFunctionBodyType
compiledFunc -> do
[AtomType]
funcAtomType <- (TypeConstructor -> Either RelationalError AtomType)
-> [TypeConstructor] -> Either RelationalError [AtomType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\TypeConstructor
funcTypeArg -> DirtyFlag
-> TypeConstructor
-> TypeConstructorMapping
-> TypeVarMap
-> Either RelationalError AtomType
atomTypeForTypeConstructorValidate DirtyFlag
False TypeConstructor
funcTypeArg (DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
currentContext) TypeVarMap
forall k a. Map k a
M.empty) [TypeConstructor]
adjustedAtomTypeCons
let updatedFuncs :: AtomFunctions
updatedFuncs = AtomFunction -> AtomFunctions -> AtomFunctions
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert AtomFunction
newAtomFunc AtomFunctions
atomFuncs
newContext :: DatabaseContext
newContext = DatabaseContext
currentContext { atomFunctions :: AtomFunctions
atomFunctions = AtomFunctions
updatedFuncs }
newAtomFunc :: AtomFunction
newAtomFunc = Function :: forall a.
AttributeName -> [AtomType] -> FunctionBody a -> Function a
Function { funcName :: AttributeName
funcName = AttributeName
funcName',
funcType :: [AtomType]
funcType = [AtomType]
funcAtomType,
funcBody :: FunctionBody AtomFunctionBodyType
funcBody = AttributeName
-> AtomFunctionBodyType -> FunctionBody AtomFunctionBodyType
forall a. AttributeName -> a -> FunctionBody a
FunctionScriptBody AttributeName
script AtomFunctionBodyType
compiledFunc }
if AttributeName -> HashSet AttributeName -> DirtyFlag
forall a. (Eq a, Hashable a) => a -> HashSet a -> DirtyFlag
HS.member AttributeName
funcName' ((AtomFunction -> AttributeName)
-> AtomFunctions -> HashSet AttributeName
forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
HS.map AtomFunction -> AttributeName
forall a. Function a -> AttributeName
funcName AtomFunctions
atomFuncs) then
RelationalError -> Either RelationalError DatabaseContext
forall a b. a -> Either a b
Left (AttributeName -> RelationalError
FunctionNameInUseError AttributeName
funcName')
else
DatabaseContext -> Either RelationalError DatabaseContext
forall a b. b -> Either a b
Right DatabaseContext
newContext
case Either SomeException (Either RelationalError DatabaseContext)
res of
Left (SomeException
exc :: SomeException) -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ()))
-> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall a b. (a -> b) -> a -> b
$ RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError ([Char] -> ScriptCompilationError
OtherScriptCompilationError (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
exc)))
Right Either RelationalError DatabaseContext
eContext -> case Either RelationalError DatabaseContext
eContext of
Left RelationalError
err -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
err)
Right DatabaseContext
context' -> DatabaseContext
-> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext DatabaseContext
context'
evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction AttributeName
funcName' [TypeConstructor]
funcType' AttributeName
script) = do
Either RelationalError ScriptSession
eScriptSession <- DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)
requireScriptSession
DatabaseContext
currentContext <- DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext
case Either RelationalError ScriptSession
eScriptSession of
Left RelationalError
err -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
err)
Right ScriptSession
scriptSession -> do
let last2Args :: [TypeConstructor]
last2Args = [TypeConstructor] -> [TypeConstructor]
forall a. [a] -> [a]
reverse (Int -> [TypeConstructor] -> [TypeConstructor]
forall a. Int -> [a] -> [a]
take Int
2 ([TypeConstructor] -> [TypeConstructor]
forall a. [a] -> [a]
reverse [TypeConstructor]
funcType'))
atomArgs :: [TypeConstructor]
atomArgs = Int -> [TypeConstructor] -> [TypeConstructor]
forall a. Int -> [a] -> [a]
take ([TypeConstructor] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeConstructor]
funcType' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) [TypeConstructor]
funcType'
dbContextTypeCons :: TypeConstructorBase a
dbContextTypeCons = AttributeName -> [TypeConstructor] -> TypeConstructorBase a
forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"Either" [AttributeName -> [TypeConstructor] -> TypeConstructor
forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"DatabaseContextFunctionError" [], AttributeName -> [TypeConstructor] -> TypeConstructor
forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"DatabaseContext" []]
expectedType :: [Char]
expectedType = [Char]
"DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"
actualType :: [Char]
actualType = [TypeConstructor] -> [Char]
forall a. Show a => a -> [Char]
show [TypeConstructor]
funcType'
if [TypeConstructor]
last2Args [TypeConstructor] -> [TypeConstructor] -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= [AttributeName -> [TypeConstructor] -> TypeConstructor
forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"DatabaseContext" [], TypeConstructor
forall a. TypeConstructorBase a
dbContextTypeCons] then
Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError ([Char] -> [Char] -> ScriptCompilationError
TypeCheckCompilationError [Char]
expectedType [Char]
actualType)))
else do
Either SomeException (Either RelationalError DatabaseContext)
res <- IO (Either SomeException (Either RelationalError DatabaseContext))
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either SomeException (Either RelationalError DatabaseContext))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException (Either RelationalError DatabaseContext))
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either SomeException (Either RelationalError DatabaseContext)))
-> IO
(Either SomeException (Either RelationalError DatabaseContext))
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either SomeException (Either RelationalError DatabaseContext))
forall a b. (a -> b) -> a -> b
$ IO (Either RelationalError DatabaseContext)
-> IO
(Either SomeException (Either RelationalError DatabaseContext))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Either RelationalError DatabaseContext)
-> IO
(Either SomeException (Either RelationalError DatabaseContext)))
-> IO (Either RelationalError DatabaseContext)
-> IO
(Either SomeException (Either RelationalError DatabaseContext))
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> Ghc (Either RelationalError DatabaseContext)
-> IO (Either RelationalError DatabaseContext)
forall a. Maybe [Char] -> Ghc a -> IO a
runGhc ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
libdir) (Ghc (Either RelationalError DatabaseContext)
-> IO (Either RelationalError DatabaseContext))
-> Ghc (Either RelationalError DatabaseContext)
-> IO (Either RelationalError DatabaseContext)
forall a b. (a -> b) -> a -> b
$ do
HscEnv -> Ghc ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (ScriptSession -> HscEnv
hscEnv ScriptSession
scriptSession)
Either ScriptCompilationError DatabaseContextFunctionBodyType
eCompiledFunc <- Type
-> AttributeName
-> Ghc
(Either ScriptCompilationError DatabaseContextFunctionBodyType)
forall a.
Type -> AttributeName -> Ghc (Either ScriptCompilationError a)
compileScript (ScriptSession -> Type
dbcFunctionBodyType ScriptSession
scriptSession) AttributeName
script
Either RelationalError DatabaseContext
-> Ghc (Either RelationalError DatabaseContext)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RelationalError DatabaseContext
-> Ghc (Either RelationalError DatabaseContext))
-> Either RelationalError DatabaseContext
-> Ghc (Either RelationalError DatabaseContext)
forall a b. (a -> b) -> a -> b
$ case Either ScriptCompilationError DatabaseContextFunctionBodyType
eCompiledFunc of
Left ScriptCompilationError
err -> RelationalError -> Either RelationalError DatabaseContext
forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError ScriptCompilationError
err)
Right DatabaseContextFunctionBodyType
compiledFunc -> do
[AtomType]
funcAtomType <- (TypeConstructor -> Either RelationalError AtomType)
-> [TypeConstructor] -> Either RelationalError [AtomType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\TypeConstructor
funcTypeArg -> TypeConstructor
-> TypeConstructorMapping
-> TypeVarMap
-> Either RelationalError AtomType
atomTypeForTypeConstructor TypeConstructor
funcTypeArg (DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
currentContext) TypeVarMap
forall k a. Map k a
M.empty) [TypeConstructor]
atomArgs
let updatedDBCFuncs :: DatabaseContextFunctions
updatedDBCFuncs = DatabaseContextFunction
-> DatabaseContextFunctions -> DatabaseContextFunctions
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert DatabaseContextFunction
newDBCFunc (DatabaseContext -> DatabaseContextFunctions
dbcFunctions DatabaseContext
currentContext)
newContext :: DatabaseContext
newContext = DatabaseContext
currentContext { dbcFunctions :: DatabaseContextFunctions
dbcFunctions = DatabaseContextFunctions
updatedDBCFuncs }
dbcFuncs :: DatabaseContextFunctions
dbcFuncs = DatabaseContext -> DatabaseContextFunctions
dbcFunctions DatabaseContext
currentContext
newDBCFunc :: DatabaseContextFunction
newDBCFunc = Function :: forall a.
AttributeName -> [AtomType] -> FunctionBody a -> Function a
Function {
funcName :: AttributeName
funcName = AttributeName
funcName',
funcType :: [AtomType]
funcType = [AtomType]
funcAtomType,
funcBody :: FunctionBody DatabaseContextFunctionBodyType
funcBody = AttributeName
-> DatabaseContextFunctionBodyType
-> FunctionBody DatabaseContextFunctionBodyType
forall a. AttributeName -> a -> FunctionBody a
FunctionScriptBody AttributeName
script DatabaseContextFunctionBodyType
compiledFunc
}
if AttributeName -> HashSet AttributeName -> DirtyFlag
forall a. (Eq a, Hashable a) => a -> HashSet a -> DirtyFlag
HS.member AttributeName
funcName' ((DatabaseContextFunction -> AttributeName)
-> DatabaseContextFunctions -> HashSet AttributeName
forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
HS.map DatabaseContextFunction -> AttributeName
forall a. Function a -> AttributeName
funcName DatabaseContextFunctions
dbcFuncs) then
RelationalError -> Either RelationalError DatabaseContext
forall a b. a -> Either a b
Left (AttributeName -> RelationalError
FunctionNameInUseError AttributeName
funcName')
else
DatabaseContext -> Either RelationalError DatabaseContext
forall a b. b -> Either a b
Right DatabaseContext
newContext
case Either SomeException (Either RelationalError DatabaseContext)
res of
Left (SomeException
exc :: SomeException) -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ()))
-> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall a b. (a -> b) -> a -> b
$ RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError ([Char] -> ScriptCompilationError
OtherScriptCompilationError (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
exc)))
Right Either RelationalError DatabaseContext
eContext -> case Either RelationalError DatabaseContext
eContext of
Left RelationalError
err -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
err)
Right DatabaseContext
context' -> DatabaseContext
-> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext DatabaseContext
context'
evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions AttributeName
modName AttributeName
entrypointName [Char]
modPath) = do
Maybe [Char]
mModDir <- DatabaseContextIOEvalEnv -> Maybe [Char]
dbcio_mModulesDirectory (DatabaseContextIOEvalEnv -> Maybe [Char])
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
DatabaseContextIOEvalEnv
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
DatabaseContextIOEvalEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
DatabaseContext
currentContext <- DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext
let sModName :: [Char]
sModName = AttributeName -> [Char]
T.unpack AttributeName
modName
sEntrypointName :: [Char]
sEntrypointName = AttributeName -> [Char]
T.unpack AttributeName
entrypointName
Either LoadSymbolError [AtomFunction]
eLoadFunc <- IO (Either LoadSymbolError [AtomFunction])
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either LoadSymbolError [AtomFunction])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either LoadSymbolError [AtomFunction])
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either LoadSymbolError [AtomFunction]))
-> IO (Either LoadSymbolError [AtomFunction])
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either LoadSymbolError [AtomFunction])
forall a b. (a -> b) -> a -> b
$ [Char]
-> [Char]
-> Maybe [Char]
-> [Char]
-> IO (Either LoadSymbolError [AtomFunction])
forall a.
[Char]
-> [Char]
-> Maybe [Char]
-> [Char]
-> IO (Either LoadSymbolError [Function a])
loadFunctions [Char]
sModName [Char]
sEntrypointName Maybe [Char]
mModDir [Char]
modPath
case Either LoadSymbolError [AtomFunction]
eLoadFunc of
Left LoadSymbolError
LoadSymbolError -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
LoadFunctionError)
Left LoadSymbolError
SecurityLoadSymbolError -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
SecurityLoadFunctionError)
Right [AtomFunction]
atomFunctionListFunc -> do
let newContext :: DatabaseContext
newContext = DatabaseContext
currentContext { atomFunctions :: AtomFunctions
atomFunctions = AtomFunctions
mergedFuncs }
processedAtomFunctions :: [AtomFunction]
processedAtomFunctions = [Char] -> [Char] -> [Char] -> [AtomFunction] -> [AtomFunction]
forall (f :: * -> *) a.
Functor f =>
[Char] -> [Char] -> [Char] -> f (Function a) -> f (Function a)
processObjectLoadedFunctions [Char]
sModName [Char]
sEntrypointName [Char]
modPath [AtomFunction]
atomFunctionListFunc
mergedFuncs :: AtomFunctions
mergedFuncs = AtomFunctions -> AtomFunctions -> AtomFunctions
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union (DatabaseContext -> AtomFunctions
atomFunctions DatabaseContext
currentContext) ([AtomFunction] -> AtomFunctions
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [AtomFunction]
processedAtomFunctions)
DatabaseContext
-> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext DatabaseContext
newContext
evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions AttributeName
modName AttributeName
entrypointName [Char]
modPath) = do
DatabaseContext
currentContext <- DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext
let sModName :: [Char]
sModName = AttributeName -> [Char]
T.unpack AttributeName
modName
sEntrypointName :: [Char]
sEntrypointName = AttributeName -> [Char]
T.unpack AttributeName
entrypointName
Maybe [Char]
mModDir <- DatabaseContextIOEvalEnv -> Maybe [Char]
dbcio_mModulesDirectory (DatabaseContextIOEvalEnv -> Maybe [Char])
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
DatabaseContextIOEvalEnv
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
DatabaseContextIOEvalEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
Either LoadSymbolError [DatabaseContextFunction]
eLoadFunc <- IO (Either LoadSymbolError [DatabaseContextFunction])
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either LoadSymbolError [DatabaseContextFunction])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either LoadSymbolError [DatabaseContextFunction])
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either LoadSymbolError [DatabaseContextFunction]))
-> IO (Either LoadSymbolError [DatabaseContextFunction])
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either LoadSymbolError [DatabaseContextFunction])
forall a b. (a -> b) -> a -> b
$ [Char]
-> [Char]
-> Maybe [Char]
-> [Char]
-> IO (Either LoadSymbolError [DatabaseContextFunction])
forall a.
[Char]
-> [Char]
-> Maybe [Char]
-> [Char]
-> IO (Either LoadSymbolError [Function a])
loadFunctions [Char]
sModName [Char]
sEntrypointName Maybe [Char]
mModDir [Char]
modPath
case Either LoadSymbolError [DatabaseContextFunction]
eLoadFunc of
Left LoadSymbolError
LoadSymbolError -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
LoadFunctionError)
Left LoadSymbolError
SecurityLoadSymbolError -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
SecurityLoadFunctionError)
Right [DatabaseContextFunction]
dbcListFunc -> let newContext :: DatabaseContext
newContext = DatabaseContext
currentContext { dbcFunctions :: DatabaseContextFunctions
dbcFunctions = DatabaseContextFunctions
mergedFuncs }
mergedFuncs :: DatabaseContextFunctions
mergedFuncs = DatabaseContextFunctions
-> DatabaseContextFunctions -> DatabaseContextFunctions
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union (DatabaseContext -> DatabaseContextFunctions
dbcFunctions DatabaseContext
currentContext) ([DatabaseContextFunction] -> DatabaseContextFunctions
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [DatabaseContextFunction]
processedDBCFuncs)
processedDBCFuncs :: [DatabaseContextFunction]
processedDBCFuncs = [Char]
-> [Char]
-> [Char]
-> [DatabaseContextFunction]
-> [DatabaseContextFunction]
forall (f :: * -> *) a.
Functor f =>
[Char] -> [Char] -> [Char] -> f (Function a) -> f (Function a)
processObjectLoadedFunctions [Char]
sModName [Char]
sEntrypointName [Char]
modPath [DatabaseContextFunction]
dbcListFunc
in DatabaseContext
-> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext DatabaseContext
newContext
#endif
evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation AttributeName
relVarName [AttributeExprBase GraphRefTransactionMarker]
attrExprs Range
range) = do
DatabaseContext
currentContext <- DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext
DatabaseContextIOEvalEnv
env <- RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
DatabaseContextIOEvalEnv
forall r (m :: * -> *). MonadReader r m => m r
RWS.ask
let gfExpr :: GraphRefDatabaseContextExpr
gfExpr = AttributeName
-> [AttributeExprBase GraphRefTransactionMarker]
-> GraphRefDatabaseContextExpr
forall a.
AttributeName -> [AttributeExprBase a] -> DatabaseContextExprBase a
Define AttributeName
relVarName [AttributeExprBase GraphRefTransactionMarker]
attrExprs
evalEnv :: DatabaseContextEvalEnv
evalEnv = TransactionId -> TransactionGraph -> DatabaseContextEvalEnv
mkDatabaseContextEvalEnv (DatabaseContextIOEvalEnv -> TransactionId
dbcio_transId DatabaseContextIOEvalEnv
env) (DatabaseContextIOEvalEnv -> TransactionGraph
dbcio_graph DatabaseContextIOEvalEnv
env)
graph :: TransactionGraph
graph = DatabaseContextIOEvalEnv -> TransactionGraph
dbcio_graph DatabaseContextIOEvalEnv
env
case DatabaseContext
-> DatabaseContextEvalEnv
-> DatabaseContextEvalMonad ()
-> Either RelationalError DatabaseContextEvalState
runDatabaseContextEvalMonad DatabaseContext
currentContext DatabaseContextEvalEnv
evalEnv (GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
evalGraphRefDatabaseContextExpr GraphRefDatabaseContextExpr
gfExpr) of
Left RelationalError
err -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
err)
Right DatabaseContextEvalState
dbstate -> do
let existingRelVar :: Maybe GraphRefRelationalExpr
existingRelVar = AttributeName
-> Map AttributeName GraphRefRelationalExpr
-> Maybe GraphRefRelationalExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
relVarName Map AttributeName GraphRefRelationalExpr
relVarTable
relVarTable :: Map AttributeName GraphRefRelationalExpr
relVarTable = DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables (DatabaseContextEvalState -> DatabaseContext
dbc_context DatabaseContextEvalState
dbstate)
case Maybe GraphRefRelationalExpr
existingRelVar of
Maybe GraphRefRelationalExpr
Nothing -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ()))
-> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall a b. (a -> b) -> a -> b
$ RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (AttributeName -> RelationalError
RelVarNotDefinedError AttributeName
relVarName)
Just GraphRefRelationalExpr
existingRel -> do
let gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (DatabaseContext -> Maybe DatabaseContext
forall a. a -> Maybe a
Just DatabaseContext
currentContext) TransactionGraph
graph
case GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
existingRel) of
Left RelationalError
err -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
err)
Right Relation
relType -> do
let expectedAttributes :: Attributes
expectedAttributes = Relation -> Attributes
attributes Relation
relType
tcMap :: TypeConstructorMapping
tcMap = DatabaseContext -> TypeConstructorMapping
typeConstructorMapping (DatabaseContextEvalState -> DatabaseContext
dbc_context DatabaseContextEvalState
dbstate)
Either RelationalError Relation
eitherRel <- IO (Either RelationalError Relation)
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either RelationalError Relation)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either RelationalError Relation)
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either RelationalError Relation))
-> IO (Either RelationalError Relation)
-> RWST
DatabaseContextIOEvalEnv
()
DatabaseContextEvalState
IO
(Either RelationalError Relation)
forall a b. (a -> b) -> a -> b
$ Gen (Either RelationalError Relation)
-> IO (Either RelationalError Relation)
forall a. Gen a -> IO a
generate (Gen (Either RelationalError Relation)
-> IO (Either RelationalError Relation))
-> Gen (Either RelationalError Relation)
-> IO (Either RelationalError Relation)
forall a b. (a -> b) -> a -> b
$ ReaderT
TypeConstructorMapping Gen (Either RelationalError Relation)
-> TypeConstructorMapping -> Gen (Either RelationalError Relation)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Attributes
-> Range
-> ReaderT
TypeConstructorMapping Gen (Either RelationalError Relation)
arbitraryRelation Attributes
expectedAttributes Range
range) TypeConstructorMapping
tcMap
case Either RelationalError Relation
eitherRel of
Left RelationalError
err -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ()))
-> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall a b. (a -> b) -> a -> b
$ RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
err
Right Relation
rel ->
case DatabaseContext
-> DatabaseContextEvalEnv
-> DatabaseContextEvalMonad ()
-> Either RelationalError DatabaseContextEvalState
runDatabaseContextEvalMonad DatabaseContext
currentContext DatabaseContextEvalEnv
evalEnv (AttributeName
-> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar AttributeName
relVarName (Relation -> GraphRefRelationalExpr
forall a. Relation -> RelationalExprBase a
ExistingRelation Relation
rel)) of
Left RelationalError
err -> Either RelationalError ()
-> DatabaseContextIOEvalMonad (Either RelationalError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
err)
Right DatabaseContextEvalState
dbstate' -> DatabaseContext
-> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext (DatabaseContextEvalState -> DatabaseContext
dbc_context DatabaseContextEvalState
dbstate')
checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints :: DatabaseContext
-> TransactionId -> TransactionGraph -> Either RelationalError ()
checkConstraints DatabaseContext
context TransactionId
transId graph :: TransactionGraph
graph@(TransactionGraph TransactionHeads
graphHeads Set Transaction
transSet) = do
((AttributeName, InclusionDependency) -> Either RelationalError ())
-> [(AttributeName, InclusionDependency)]
-> Either RelationalError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((AttributeName -> InclusionDependency -> Either RelationalError ())
-> (AttributeName, InclusionDependency)
-> Either RelationalError ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry AttributeName -> InclusionDependency -> Either RelationalError ()
checkIncDep) (InclusionDependencies -> [(AttributeName, InclusionDependency)]
forall k a. Map k a -> [(k, a)]
M.toList InclusionDependencies
deps)
((AttributeName, RelationalExpr) -> Either RelationalError ())
-> [(AttributeName, RelationalExpr)] -> Either RelationalError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AttributeName, RelationalExpr) -> Either RelationalError ()
checkRegisteredQuery (Map AttributeName RelationalExpr
-> [(AttributeName, RelationalExpr)]
forall k a. Map k a -> [(k, a)]
M.toList (DatabaseContext -> Map AttributeName RelationalExpr
registeredQueries DatabaseContext
context))
where
potentialGraph :: TransactionGraph
potentialGraph = TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph TransactionHeads
graphHeads (Transaction -> Set Transaction -> Set Transaction
forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
tempTrans Set Transaction
transSet)
tempStamp :: UTCTime
tempStamp = UTCTime :: Day -> DiffTime -> UTCTime
UTCTime { utctDay :: Day
utctDay = Integer -> Int -> Int -> Day
fromGregorian Integer
2000 Int
1 Int
1,
utctDayTime :: DiffTime
utctDayTime = Integer -> DiffTime
secondsToDiffTime Integer
0 }
tempSchemas :: Schemas
tempSchemas = DatabaseContext -> Subschemas -> Schemas
Schemas DatabaseContext
context Subschemas
forall k a. Map k a
M.empty
tempTrans :: Transaction
tempTrans = TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
U.nil TransactionInfo
tempTransInfo Schemas
tempSchemas
tempTransInfo :: TransactionInfo
tempTransInfo = TransactionInfo :: TransactionParents -> UTCTime -> MerkleHash -> TransactionInfo
TransactionInfo { parents :: TransactionParents
parents = TransactionId
transId TransactionId -> [TransactionId] -> TransactionParents
forall a. a -> [a] -> NonEmpty a
NE.:| [],
stamp :: UTCTime
stamp = UTCTime
tempStamp,
merkleHash :: MerkleHash
merkleHash = MerkleHash
forall a. Monoid a => a
mempty
}
deps :: InclusionDependencies
deps = DatabaseContext -> InclusionDependencies
inclusionDependencies DatabaseContext
context
process :: ProcessExprM a -> a
process = GraphRefTransactionMarker -> ProcessExprM a -> a
forall a. GraphRefTransactionMarker -> ProcessExprM a -> a
runProcessExprM GraphRefTransactionMarker
UncommittedContextMarker
gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (DatabaseContext -> Maybe DatabaseContext
forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
checkIncDep :: AttributeName -> InclusionDependency -> Either RelationalError ()
checkIncDep AttributeName
depName (InclusionDependency RelationalExpr
subsetExpr RelationalExpr
supersetExpr) = do
let gfSubsetExpr :: GraphRefRelationalExpr
gfSubsetExpr = ProcessExprM GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a. ProcessExprM a -> a
process (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
subsetExpr)
gfSupersetExpr :: GraphRefRelationalExpr
gfSupersetExpr = ProcessExprM GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a. ProcessExprM a -> a
process (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
supersetExpr)
runGfRel :: GraphRefRelationalExprM b -> Either RelationalError b
runGfRel GraphRefRelationalExprM b
e = case GraphRefRelationalExprEnv
-> GraphRefRelationalExprM b -> Either RelationalError b
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv GraphRefRelationalExprM b
e of
Left RelationalError
err -> RelationalError -> Either RelationalError b
forall a b. a -> Either a b
Left (Maybe RelationalError -> RelationalError
wrapIncDepErr (RelationalError -> Maybe RelationalError
forall a. a -> Maybe a
Just RelationalError
err))
Right b
v -> b -> Either RelationalError b
forall a b. b -> Either a b
Right b
v
wrapIncDepErr :: Maybe RelationalError -> RelationalError
wrapIncDepErr = AttributeName -> Maybe RelationalError -> RelationalError
InclusionDependencyCheckError AttributeName
depName
Relation
typeSub <- GraphRefRelationalExprM Relation -> Either RelationalError Relation
forall b. GraphRefRelationalExprM b -> Either RelationalError b
runGfRel (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfSubsetExpr)
Relation
typeSuper <- GraphRefRelationalExprM Relation -> Either RelationalError Relation
forall b. GraphRefRelationalExprM b -> Either RelationalError b
runGfRel (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfSupersetExpr)
DirtyFlag -> Either RelationalError () -> Either RelationalError ()
forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
when (Relation
typeSub Relation -> Relation -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= Relation
typeSuper) (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (Maybe RelationalError -> RelationalError
wrapIncDepErr (RelationalError -> Maybe RelationalError
forall a. a -> Maybe a
Just (Attributes -> Attributes -> RelationalError
RelationTypeMismatchError (Relation -> Attributes
attributes Relation
typeSub) (Relation -> Attributes
attributes Relation
typeSuper)))))
let checkExpr :: GraphRefRelationalExpr
checkExpr = GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Equals GraphRefRelationalExpr
gfSupersetExpr (GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union GraphRefRelationalExpr
gfSubsetExpr GraphRefRelationalExpr
gfSupersetExpr)
gfEvald :: Either RelationalError Relation
gfEvald = GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv' (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
checkExpr)
gfEnv' :: GraphRefRelationalExprEnv
gfEnv' = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (DatabaseContext -> Maybe DatabaseContext
forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
potentialGraph
case Either RelationalError Relation
gfEvald of
Left RelationalError
err -> RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (Maybe RelationalError -> RelationalError
wrapIncDepErr (RelationalError -> Maybe RelationalError
forall a. a -> Maybe a
Just RelationalError
err))
Right Relation
resultRel -> if Relation
resultRel Relation -> Relation -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== Relation
relationTrue then
() -> Either RelationalError ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else
RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (Maybe RelationalError -> RelationalError
wrapIncDepErr Maybe RelationalError
forall a. Maybe a
Nothing)
checkRegisteredQuery :: (AttributeName, RelationalExpr) -> Either RelationalError ()
checkRegisteredQuery (AttributeName
qName, RelationalExpr
relExpr) = do
let gfExpr :: GraphRefRelationalExpr
gfExpr = ProcessExprM GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a. ProcessExprM a -> a
process (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
relExpr)
case GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfExpr) of
Left RelationalError
err -> RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (AttributeName -> RelationalError -> RelationalError
RegisteredQueryValidationError AttributeName
qName RelationalError
err)
Right Relation
_ -> () -> Either RelationalError ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation
typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation
typeForRelationalExpr RelationalExpr
expr = do
TransactionGraph
graph <- RelationalExprM TransactionGraph
reGraph
DatabaseContext
context <- RelationalExprM DatabaseContext
reContext
let gfExpr :: GraphRefRelationalExpr
gfExpr = GraphRefTransactionMarker
-> ProcessExprM GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a. GraphRefTransactionMarker -> ProcessExprM a -> a
runProcessExprM GraphRefTransactionMarker
UncommittedContextMarker (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
expr)
gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (DatabaseContext -> Maybe DatabaseContext
forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
runGf :: Either RelationalError Relation
runGf = GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfExpr)
ExceptT RelationalError Identity Relation
-> RelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> RelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> RelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except Either RelationalError Relation
runGf
liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
liftE :: m (Either a b) -> ExceptT a m b
liftE m (Either a b)
v = do
Either a b
y <- m (Either a b) -> ExceptT a m (Either a b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Either a b)
v
case Either a b
y of
Left a
err -> a -> ExceptT a m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a
err
Right b
val -> b -> ExceptT a m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
val
predicateRestrictionFilter :: Attributes -> GraphRefRestrictionPredicateExpr -> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter :: Attributes
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter Attributes
attrs (AndPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
expr1 RestrictionPredicateExprBase GraphRefTransactionMarker
expr2) = do
RestrictionFilter
expr1v <- Attributes
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter Attributes
attrs RestrictionPredicateExprBase GraphRefTransactionMarker
expr1
RestrictionFilter
expr2v <- Attributes
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter Attributes
attrs RestrictionPredicateExprBase GraphRefTransactionMarker
expr2
RestrictionFilter -> GraphRefRelationalExprM RestrictionFilter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\RelationTuple
x -> do
DirtyFlag
ev1 <- RestrictionFilter
expr1v RelationTuple
x
DirtyFlag
ev2 <- RestrictionFilter
expr2v RelationTuple
x
DirtyFlag -> Either RelationalError DirtyFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DirtyFlag
ev1 DirtyFlag -> DirtyFlag -> DirtyFlag
&& DirtyFlag
ev2))
predicateRestrictionFilter Attributes
attrs (OrPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
expr1 RestrictionPredicateExprBase GraphRefTransactionMarker
expr2) = do
RestrictionFilter
expr1v <- Attributes
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter Attributes
attrs RestrictionPredicateExprBase GraphRefTransactionMarker
expr1
RestrictionFilter
expr2v <- Attributes
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter Attributes
attrs RestrictionPredicateExprBase GraphRefTransactionMarker
expr2
RestrictionFilter -> GraphRefRelationalExprM RestrictionFilter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\RelationTuple
x -> do
DirtyFlag
ev1 <- RestrictionFilter
expr1v RelationTuple
x
DirtyFlag
ev2 <- RestrictionFilter
expr2v RelationTuple
x
DirtyFlag -> Either RelationalError DirtyFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DirtyFlag
ev1 DirtyFlag -> DirtyFlag -> DirtyFlag
|| DirtyFlag
ev2))
predicateRestrictionFilter Attributes
_ RestrictionPredicateExprBase GraphRefTransactionMarker
TruePredicate = RestrictionFilter -> GraphRefRelationalExprM RestrictionFilter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\RelationTuple
_ -> DirtyFlag -> Either RelationalError DirtyFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure DirtyFlag
True)
predicateRestrictionFilter Attributes
attrs (NotPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
expr) = do
RestrictionFilter
exprv <- Attributes
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter Attributes
attrs RestrictionPredicateExprBase GraphRefTransactionMarker
expr
RestrictionFilter -> GraphRefRelationalExprM RestrictionFilter
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((DirtyFlag -> DirtyFlag)
-> Either RelationalError DirtyFlag
-> Either RelationalError DirtyFlag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DirtyFlag -> DirtyFlag
not (Either RelationalError DirtyFlag
-> Either RelationalError DirtyFlag)
-> RestrictionFilter -> RestrictionFilter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RestrictionFilter
exprv)
predicateRestrictionFilter Attributes
_ (RelationalExprPredicate GraphRefRelationalExpr
relExpr) = do
GraphRefRelationalExprEnv
renv <- GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv
let eval :: RelationTuple -> Either RelationalError Relation
eval :: RelationTuple -> Either RelationalError Relation
eval RelationTuple
tup =
let gfEnv :: GraphRefRelationalExprEnv
gfEnv = RelationTuple
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeTuplesIntoGraphRefRelationalExprEnv RelationTuple
tup GraphRefRelationalExprEnv
renv in
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
relExpr)
RestrictionFilter -> GraphRefRelationalExprM RestrictionFilter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\RelationTuple
tup -> case RelationTuple -> Either RelationalError Relation
eval RelationTuple
tup of
Left RelationalError
err -> RelationalError -> Either RelationalError DirtyFlag
forall a b. a -> Either a b
Left RelationalError
err
Right Relation
rel -> if Relation -> Int
arity Relation
rel Int -> Int -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= Int
0 then
RelationalError -> Either RelationalError DirtyFlag
forall a b. a -> Either a b
Left (AttributeName -> RelationalError
PredicateExpressionError AttributeName
"Relational restriction filter must evaluate to 'true' or 'false'")
else
DirtyFlag -> Either RelationalError DirtyFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Relation
rel Relation -> Relation -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== Relation
relationTrue))
predicateRestrictionFilter Attributes
attrs (AttributeEqualityPredicate AttributeName
attrName GraphRefAtomExpr
atomExpr) = do
GraphRefRelationalExprEnv
env <- GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv
let attrs' :: Attributes
attrs' = Attributes -> Attributes -> Attributes
A.union Attributes
attrs (GraphRefRelationalExprEnv -> Attributes
envAttributes GraphRefRelationalExprEnv
env)
ctxtup' :: RelationTuple
ctxtup' = GraphRefRelationalExprEnv -> RelationTuple
envTuple GraphRefRelationalExprEnv
env
AtomType
atomExprType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
attrs' GraphRefAtomExpr
atomExpr
Attribute
attr <- ExceptT RelationalError Identity Attribute
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Attribute
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute)
-> ExceptT RelationalError Identity Attribute
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
forall a b. (a -> b) -> a -> b
$ Either RelationalError Attribute
-> ExceptT RelationalError Identity Attribute
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Attribute
-> ExceptT RelationalError Identity Attribute)
-> Either RelationalError Attribute
-> ExceptT RelationalError Identity Attribute
forall a b. (a -> b) -> a -> b
$ case AttributeName -> Attributes -> Either RelationalError Attribute
A.attributeForName AttributeName
attrName Attributes
attrs' of
Right Attribute
attr -> Attribute -> Either RelationalError Attribute
forall a b. b -> Either a b
Right Attribute
attr
Left (NoSuchAttributeNamesError Set AttributeName
_) -> case AttributeName -> Attributes -> Either RelationalError Attribute
A.attributeForName AttributeName
attrName (RelationTuple -> Attributes
tupleAttributes RelationTuple
ctxtup') of
Right Attribute
ctxattr -> Attribute -> Either RelationalError Attribute
forall a b. b -> Either a b
Right Attribute
ctxattr
Left err2 :: RelationalError
err2@(NoSuchAttributeNamesError Set AttributeName
_) -> RelationalError -> Either RelationalError Attribute
forall a b. a -> Either a b
Left RelationalError
err2
Left RelationalError
err -> RelationalError -> Either RelationalError Attribute
forall a b. a -> Either a b
Left RelationalError
err
Left RelationalError
err -> RelationalError -> Either RelationalError Attribute
forall a b. a -> Either a b
Left RelationalError
err
if AtomType
atomExprType AtomType -> AtomType -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= Attribute -> AtomType
A.atomType Attribute
attr then
RelationalError -> GraphRefRelationalExprM RestrictionFilter
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Attributes -> RelationalError
TupleAttributeTypeMismatchError ([Attribute] -> Attributes
A.attributesFromList [Attribute
attr]))
else
RestrictionFilter -> GraphRefRelationalExprM RestrictionFilter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RestrictionFilter -> GraphRefRelationalExprM RestrictionFilter)
-> RestrictionFilter -> GraphRefRelationalExprM RestrictionFilter
forall a b. (a -> b) -> a -> b
$ \RelationTuple
tupleIn -> let evalAndCmp :: Atom -> DirtyFlag
evalAndCmp Atom
atomIn = case Either RelationalError Atom
atomEvald of
Right Atom
atomCmp -> Atom
atomCmp Atom -> Atom -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== Atom
atomIn
Left RelationalError
_ -> DirtyFlag
False
atomEvald :: Either RelationalError Atom
atomEvald = GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Atom -> Either RelationalError Atom
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
env (RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupleIn GraphRefAtomExpr
atomExpr)
in
DirtyFlag -> Either RelationalError DirtyFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DirtyFlag -> Either RelationalError DirtyFlag)
-> DirtyFlag -> Either RelationalError DirtyFlag
forall a b. (a -> b) -> a -> b
$ case AttributeName -> RelationTuple -> Either RelationalError Atom
atomForAttributeName AttributeName
attrName RelationTuple
tupleIn of
Left (NoSuchAttributeNamesError Set AttributeName
_) -> case AttributeName -> RelationTuple -> Either RelationalError Atom
atomForAttributeName AttributeName
attrName RelationTuple
ctxtup' of
Left RelationalError
_ -> DirtyFlag
False
Right Atom
ctxatom -> Atom -> DirtyFlag
evalAndCmp Atom
ctxatom
Left RelationalError
_ -> DirtyFlag
False
Right Atom
atomIn -> Atom -> DirtyFlag
evalAndCmp Atom
atomIn
predicateRestrictionFilter Attributes
attrs (AtomExprPredicate GraphRefAtomExpr
atomExpr) = do
GraphRefRelationalExprEnv
renv <- GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv
AtomType
aType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
attrs GraphRefAtomExpr
atomExpr
if AtomType
aType AtomType -> AtomType -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= AtomType
BoolAtomType then
RelationalError -> GraphRefRelationalExprM RestrictionFilter
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomType -> AtomType -> RelationalError
AtomTypeMismatchError AtomType
aType AtomType
BoolAtomType)
else
RestrictionFilter -> GraphRefRelationalExprM RestrictionFilter
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\RelationTuple
tupleIn ->
case GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Atom -> Either RelationalError Atom
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
renv (RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupleIn GraphRefAtomExpr
atomExpr) of
Left RelationalError
err -> RelationalError -> Either RelationalError DirtyFlag
forall a b. a -> Either a b
Left RelationalError
err
Right Atom
boolAtomValue -> DirtyFlag -> Either RelationalError DirtyFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom
boolAtomValue Atom -> Atom -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== DirtyFlag -> Atom
BoolAtom DirtyFlag
True))
tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
tupleExprCheckNewAttrName AttributeName
attrName Relation
rel = if Either RelationalError Attribute -> DirtyFlag
forall a b. Either a b -> DirtyFlag
isRight (AttributeName -> Relation -> Either RelationalError Attribute
attributeForName AttributeName
attrName Relation
rel) then
RelationalError -> Either RelationalError Relation
forall a b. a -> Either a b
Left (AttributeName -> RelationalError
AttributeNameInUseError AttributeName
attrName)
else
Relation -> Either RelationalError Relation
forall a b. b -> Either a b
Right Relation
rel
extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)
extendGraphRefTupleExpressionProcessor :: Relation
-> GraphRefExtendTupleExpr
-> GraphRefRelationalExprM
(Attributes, RelationTuple -> Either RelationalError RelationTuple)
extendGraphRefTupleExpressionProcessor Relation
relIn (AttributeExtendTupleExpr AttributeName
newAttrName GraphRefAtomExpr
atomExpr) =
case AttributeName -> Relation -> Either RelationalError Relation
tupleExprCheckNewAttrName AttributeName
newAttrName Relation
relIn of
Left RelationalError
err -> RelationalError
-> GraphRefRelationalExprM
(Attributes, RelationTuple -> Either RelationalError RelationTuple)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right Relation
_ -> do
AtomType
atomExprType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr (Relation -> Attributes
attributes Relation
relIn) GraphRefAtomExpr
atomExpr
AtomType
atomExprType' <- Relation
-> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType
verifyGraphRefAtomExprTypes Relation
relIn GraphRefAtomExpr
atomExpr AtomType
atomExprType
let newAttrs :: Attributes
newAttrs = [Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
newAttrName AtomType
atomExprType']
newAndOldAttrs :: Attributes
newAndOldAttrs = Attributes -> Attributes -> Attributes
A.addAttributes (Relation -> Attributes
attributes Relation
relIn) Attributes
newAttrs
GraphRefRelationalExprEnv
env <- GraphRefRelationalExprM GraphRefRelationalExprEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
(Attributes, RelationTuple -> Either RelationalError RelationTuple)
-> GraphRefRelationalExprM
(Attributes, RelationTuple -> Either RelationalError RelationTuple)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes
newAndOldAttrs, \RelationTuple
tup -> do
let gfEnv :: GraphRefRelationalExprEnv
gfEnv = RelationTuple
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeTuplesIntoGraphRefRelationalExprEnv RelationTuple
tup GraphRefRelationalExprEnv
env
Atom
atom <- GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Atom -> Either RelationalError Atom
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tup GraphRefAtomExpr
atomExpr)
RelationTuple -> Either RelationalError RelationTuple
forall a b. b -> Either a b
Right (AttributeName -> Atom -> RelationTuple -> RelationTuple
tupleAtomExtend AttributeName
newAttrName Atom
atom RelationTuple
tup)
)
evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupIn (AttributeAtomExpr AttributeName
attrName) =
case AttributeName -> RelationTuple -> Either RelationalError Atom
atomForAttributeName AttributeName
attrName RelationTuple
tupIn of
Right Atom
atom -> Atom -> GraphRefRelationalExprM Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
atom
Left err :: RelationalError
err@(NoSuchAttributeNamesError Set AttributeName
_) -> do
GraphRefRelationalExprEnv
env <- GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv
case GraphRefRelationalExprEnv
-> Maybe (Either RelationTuple Attributes)
gre_extra GraphRefRelationalExprEnv
env of
Maybe (Either RelationTuple Attributes)
Nothing -> RelationalError -> GraphRefRelationalExprM Atom
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Just (Left RelationTuple
ctxtup) -> ExceptT RelationalError Identity Atom
-> GraphRefRelationalExprM Atom
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Atom
-> GraphRefRelationalExprM Atom)
-> ExceptT RelationalError Identity Atom
-> GraphRefRelationalExprM Atom
forall a b. (a -> b) -> a -> b
$ Either RelationalError Atom
-> ExceptT RelationalError Identity Atom
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Atom
-> ExceptT RelationalError Identity Atom)
-> Either RelationalError Atom
-> ExceptT RelationalError Identity Atom
forall a b. (a -> b) -> a -> b
$ AttributeName -> RelationTuple -> Either RelationalError Atom
atomForAttributeName AttributeName
attrName RelationTuple
ctxtup
Just (Right Attributes
_) -> RelationalError -> GraphRefRelationalExprM Atom
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Left RelationalError
err -> RelationalError -> GraphRefRelationalExprM Atom
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
evalGraphRefAtomExpr RelationTuple
_ (NakedAtomExpr Atom
atom) = Atom -> GraphRefRelationalExprM Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
atom
evalGraphRefAtomExpr RelationTuple
tupIn (FunctionAtomExpr AttributeName
funcName' [GraphRefAtomExpr]
arguments GraphRefTransactionMarker
tid) = do
[AtomType]
argTypes <- (GraphRefAtomExpr -> GraphRefRelationalExprM AtomType)
-> [GraphRefAtomExpr]
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
[AtomType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr (RelationTuple -> Attributes
tupleAttributes RelationTuple
tupIn)) [GraphRefAtomExpr]
arguments
DatabaseContext
context <- GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
tid
let functions :: AtomFunctions
functions = DatabaseContext -> AtomFunctions
atomFunctions DatabaseContext
context
AtomFunction
func <- ExceptT RelationalError Identity AtomFunction
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
AtomFunction
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomFunction
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
AtomFunction)
-> ExceptT RelationalError Identity AtomFunction
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
AtomFunction
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomFunction
-> ExceptT RelationalError Identity AtomFunction
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (AttributeName
-> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName AttributeName
funcName' AtomFunctions
functions)
let expectedArgCount :: Int
expectedArgCount = [AtomType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (AtomFunction -> [AtomType]
forall a. Function a -> [AtomType]
funcType AtomFunction
func) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
actualArgCount :: Int
actualArgCount = [AtomType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AtomType]
argTypes
safeInit :: [a] -> [a]
safeInit [] = []
safeInit [a]
xs = [a] -> [a]
forall a. [a] -> [a]
init [a]
xs
if Int
expectedArgCount Int -> Int -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= Int
actualArgCount then
RelationalError -> GraphRefRelationalExprM Atom
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Int -> Int -> RelationalError
FunctionArgumentCountMismatchError Int
expectedArgCount Int
actualArgCount)
else do
let zippedArgs :: [(AtomType, AtomType)]
zippedArgs = [AtomType] -> [AtomType] -> [(AtomType, AtomType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([AtomType] -> [AtomType]
forall a. [a] -> [a]
safeInit (AtomFunction -> [AtomType]
forall a. Function a -> [AtomType]
funcType AtomFunction
func)) [AtomType]
argTypes
((AtomType, AtomType) -> GraphRefRelationalExprM AtomType)
-> [(AtomType, AtomType)]
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(AtomType
expType, AtomType
actType) ->
ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expType AtomType
actType)) [(AtomType, AtomType)]
zippedArgs
[Atom]
evaldArgs <- (GraphRefAtomExpr -> GraphRefRelationalExprM Atom)
-> [GraphRefAtomExpr]
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) [Atom]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupIn) [GraphRefAtomExpr]
arguments
case AtomFunction -> AtomFunctionBodyType
evalAtomFunction AtomFunction
func [Atom]
evaldArgs of
Left AtomFunctionError
err -> RelationalError -> GraphRefRelationalExprM Atom
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomFunctionError -> RelationalError
AtomFunctionUserError AtomFunctionError
err)
Right Atom
result -> do
AtomType
_ <- ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify ([AtomType] -> AtomType
forall a. [a] -> a
last (AtomFunction -> [AtomType]
forall a. Function a -> [AtomType]
funcType AtomFunction
func)) (Atom -> AtomType
atomTypeForAtom Atom
result))
Atom -> GraphRefRelationalExprM Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
result
evalGraphRefAtomExpr RelationTuple
tupIn (RelationAtomExpr GraphRefRelationalExpr
relExpr) = do
GraphRefRelationalExprEnv
env <- GraphRefRelationalExprM GraphRefRelationalExprEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
let gfEnv :: GraphRefRelationalExprEnv
gfEnv = RelationTuple
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeTuplesIntoGraphRefRelationalExprEnv RelationTuple
tupIn GraphRefRelationalExprEnv
env
Relation
relAtom <- ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
relExpr)
Atom -> GraphRefRelationalExprM Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Relation -> Atom
RelationAtom Relation
relAtom)
evalGraphRefAtomExpr RelationTuple
_ (ConstructedAtomExpr AttributeName
tOrF [] GraphRefTransactionMarker
_)
| AttributeName
tOrF AttributeName -> AttributeName -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== AttributeName
"True" = Atom -> GraphRefRelationalExprM Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DirtyFlag -> Atom
BoolAtom DirtyFlag
True)
| AttributeName
tOrF AttributeName -> AttributeName -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== AttributeName
"False" = Atom -> GraphRefRelationalExprM Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DirtyFlag -> Atom
BoolAtom DirtyFlag
False)
evalGraphRefAtomExpr RelationTuple
tupIn cons :: GraphRefAtomExpr
cons@(ConstructedAtomExpr AttributeName
dConsName [GraphRefAtomExpr]
dConsArgs GraphRefTransactionMarker
_) = do
let mergeEnv :: GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeEnv = RelationTuple
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeTuplesIntoGraphRefRelationalExprEnv RelationTuple
tupIn
AtomType
aType <- (GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv)
-> GraphRefRelationalExprM AtomType
-> GraphRefRelationalExprM AtomType
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeEnv (Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr (RelationTuple -> Attributes
tupleAttributes RelationTuple
tupIn) GraphRefAtomExpr
cons)
[Atom]
argAtoms <- (GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv)
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) [Atom]
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) [Atom]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeEnv (ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) [Atom]
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
[Atom])
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) [Atom]
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) [Atom]
forall a b. (a -> b) -> a -> b
$
(GraphRefAtomExpr -> GraphRefRelationalExprM Atom)
-> [GraphRefAtomExpr]
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) [Atom]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupIn) [GraphRefAtomExpr]
dConsArgs
Atom -> GraphRefRelationalExprM Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AttributeName -> AtomType -> [Atom] -> Atom
ConstructedAtom AttributeName
dConsName AtomType
aType [Atom]
argAtoms)
typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
attrs (AttributeAtomExpr AttributeName
attrName) = do
GraphRefRelationalExprEnv
renv <- GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv
case AttributeName -> Attributes -> Either RelationalError AtomType
A.atomTypeForAttributeName AttributeName
attrName Attributes
attrs of
Right AtomType
aType -> AtomType -> GraphRefRelationalExprM AtomType
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomType
aType
Left err :: RelationalError
err@(NoSuchAttributeNamesError Set AttributeName
_) ->
let envTup :: RelationTuple
envTup = GraphRefRelationalExprEnv -> RelationTuple
envTuple GraphRefRelationalExprEnv
renv
envAttrs :: Attributes
envAttrs = GraphRefRelationalExprEnv -> Attributes
envAttributes GraphRefRelationalExprEnv
renv in
case AttributeName -> Attributes -> Either RelationalError Attribute
A.attributeForName AttributeName
attrName Attributes
envAttrs of
Right Attribute
attr -> AtomType -> GraphRefRelationalExprM AtomType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> AtomType
A.atomType Attribute
attr)
Left RelationalError
_ -> case AttributeName -> RelationTuple -> Either RelationalError Atom
atomForAttributeName AttributeName
attrName RelationTuple
envTup of
Right Atom
atom -> AtomType -> GraphRefRelationalExprM AtomType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom -> AtomType
atomTypeForAtom Atom
atom)
Left RelationalError
_ ->
RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Left RelationalError
err -> RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
typeForGraphRefAtomExpr Attributes
_ (NakedAtomExpr Atom
atom) = AtomType -> GraphRefRelationalExprM AtomType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom -> AtomType
atomTypeForAtom Atom
atom)
typeForGraphRefAtomExpr Attributes
attrs (FunctionAtomExpr AttributeName
funcName' [GraphRefAtomExpr]
atomArgs GraphRefTransactionMarker
transId) = do
AtomFunctions
funcs <- DatabaseContext -> AtomFunctions
atomFunctions (DatabaseContext -> AtomFunctions)
-> GraphRefRelationalExprM DatabaseContext
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
AtomFunctions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
transId
case AttributeName
-> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName AttributeName
funcName' AtomFunctions
funcs of
Left RelationalError
err -> RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right AtomFunction
func -> do
let funcRetType :: AtomType
funcRetType = [AtomType] -> AtomType
forall a. [a] -> a
last (AtomFunction -> [AtomType]
forall a. Function a -> [AtomType]
funcType AtomFunction
func)
funcArgTypes :: [AtomType]
funcArgTypes = [AtomType] -> [AtomType]
forall a. [a] -> [a]
init (AtomFunction -> [AtomType]
forall a. Function a -> [AtomType]
funcType AtomFunction
func)
funArgCount :: Int
funArgCount = [AtomType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AtomType]
funcArgTypes
inArgCount :: Int
inArgCount = [GraphRefAtomExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GraphRefAtomExpr]
atomArgs
DirtyFlag
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
when (Int
funArgCount Int -> Int -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= Int
inArgCount) (RelationalError
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Int -> Int -> RelationalError
FunctionArgumentCountMismatchError Int
funArgCount Int
inArgCount))
[AtomType]
argTypes <- (GraphRefAtomExpr -> GraphRefRelationalExprM AtomType)
-> [GraphRefAtomExpr]
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
[AtomType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
attrs) [GraphRefAtomExpr]
atomArgs
((AtomType, AtomType, Int) -> GraphRefRelationalExprM AtomType)
-> [(AtomType, AtomType, Int)]
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(AtomType
fArg,AtomType
arg,Int
argCount) -> do
let handler :: RelationalError -> GraphRefRelationalExprM AtomType
handler :: RelationalError -> GraphRefRelationalExprM AtomType
handler (AtomTypeMismatchError AtomType
expSubType AtomType
actSubType) = RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AttributeName -> Int -> AtomType -> AtomType -> RelationalError
AtomFunctionTypeError AttributeName
funcName' Int
argCount AtomType
expSubType AtomType
actSubType)
handler RelationalError
err = RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
fArg AtomType
arg) GraphRefRelationalExprM AtomType
-> (RelationalError -> GraphRefRelationalExprM AtomType)
-> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` RelationalError -> GraphRefRelationalExprM AtomType
handler
) ([AtomType] -> [AtomType] -> [Int] -> [(AtomType, AtomType, Int)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [AtomType]
funcArgTypes [AtomType]
argTypes [Int
1..])
let eTvMap :: Either RelationalError TypeVarMap
eTvMap = [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap
resolveTypeVariables [AtomType]
funcArgTypes [AtomType]
argTypes
case Either RelationalError TypeVarMap
eTvMap of
Left RelationalError
err -> RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right TypeVarMap
tvMap ->
ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ AttributeName
-> TypeVarMap -> AtomType -> Either RelationalError AtomType
resolveFunctionReturnValue AttributeName
funcName' TypeVarMap
tvMap AtomType
funcRetType
typeForGraphRefAtomExpr Attributes
attrs (RelationAtomExpr GraphRefRelationalExpr
relExpr) = do
Relation
relType <- (GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv)
-> GraphRefRelationalExprM Relation
-> GraphRefRelationalExprM Relation
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
R.local (Attributes
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeAttributesIntoGraphRefRelationalExprEnv Attributes
attrs) (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
relExpr)
AtomType -> GraphRefRelationalExprM AtomType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes -> AtomType
RelationAtomType (Relation -> Attributes
attributes Relation
relType))
typeForGraphRefAtomExpr Attributes
_ (ConstructedAtomExpr AttributeName
tOrF [] GraphRefTransactionMarker
_) | AttributeName
tOrF AttributeName -> [AttributeName] -> DirtyFlag
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DirtyFlag
`elem` [AttributeName
"True", AttributeName
"False"] =
AtomType -> GraphRefRelationalExprM AtomType
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomType
BoolAtomType
typeForGraphRefAtomExpr Attributes
attrs (ConstructedAtomExpr AttributeName
dConsName [GraphRefAtomExpr]
dConsArgs GraphRefTransactionMarker
tid) =
do
[AtomType]
argsTypes <- (GraphRefAtomExpr -> GraphRefRelationalExprM AtomType)
-> [GraphRefAtomExpr]
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
[AtomType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
attrs) [GraphRefAtomExpr]
dConsArgs
TypeConstructorMapping
tConsMap <- DatabaseContext -> TypeConstructorMapping
typeConstructorMapping (DatabaseContext -> TypeConstructorMapping)
-> GraphRefRelationalExprM DatabaseContext
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
TypeConstructorMapping
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
tid
ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ TypeConstructorMapping
-> AttributeName -> [AtomType] -> Either RelationalError AtomType
atomTypeForDataConstructor TypeConstructorMapping
tConsMap AttributeName
dConsName [AtomType]
argsTypes
verifyGraphRefAtomExprTypes :: Relation -> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType
verifyGraphRefAtomExprTypes :: Relation
-> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType
verifyGraphRefAtomExprTypes Relation
relIn (AttributeAtomExpr AttributeName
attrName) AtomType
expectedType = do
GraphRefRelationalExprEnv
env <- GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv
case AttributeName -> Attributes -> Either RelationalError AtomType
A.atomTypeForAttributeName AttributeName
attrName (Relation -> Attributes
attributes Relation
relIn) of
Right AtomType
aType -> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expectedType AtomType
aType
(Left err :: RelationalError
err@(NoSuchAttributeNamesError Set AttributeName
_)) ->
let attrs' :: Attributes
attrs' = GraphRefRelationalExprEnv -> Attributes
envAttributes GraphRefRelationalExprEnv
env in
if Attributes
attrs' Attributes -> Attributes -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== Attributes
emptyAttributes then
RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
else
case AttributeName -> Attributes -> Either RelationalError Attribute
A.attributeForName AttributeName
attrName Attributes
attrs' of
Left RelationalError
err' -> RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err'
Right Attribute
attrType -> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expectedType (Attribute -> AtomType
A.atomType Attribute
attrType)
Left RelationalError
err -> RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
verifyGraphRefAtomExprTypes Relation
_ (NakedAtomExpr Atom
atom) AtomType
expectedType =
ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expectedType (Atom -> AtomType
atomTypeForAtom Atom
atom)
verifyGraphRefAtomExprTypes Relation
relIn (FunctionAtomExpr AttributeName
funcName' [GraphRefAtomExpr]
funcArgExprs GraphRefTransactionMarker
tid) AtomType
expectedType = do
DatabaseContext
context <- GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
tid
let functions :: AtomFunctions
functions = DatabaseContext -> AtomFunctions
atomFunctions DatabaseContext
context
AtomFunction
func <- ExceptT RelationalError Identity AtomFunction
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
AtomFunction
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomFunction
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
AtomFunction)
-> ExceptT RelationalError Identity AtomFunction
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
AtomFunction
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomFunction
-> ExceptT RelationalError Identity AtomFunction
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomFunction
-> ExceptT RelationalError Identity AtomFunction)
-> Either RelationalError AtomFunction
-> ExceptT RelationalError Identity AtomFunction
forall a b. (a -> b) -> a -> b
$ AttributeName
-> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName AttributeName
funcName' AtomFunctions
functions
let expectedArgTypes :: [AtomType]
expectedArgTypes = AtomFunction -> [AtomType]
forall a. Function a -> [AtomType]
funcType AtomFunction
func
funcArgVerifier :: (GraphRefAtomExpr, AtomType, Int)
-> GraphRefRelationalExprM AtomType
funcArgVerifier (GraphRefAtomExpr
atomExpr, AtomType
expectedType2, Int
argCount) = do
let handler :: RelationalError -> GraphRefRelationalExprM AtomType
handler :: RelationalError -> GraphRefRelationalExprM AtomType
handler (AtomTypeMismatchError AtomType
expSubType AtomType
actSubType) = RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AttributeName -> Int -> AtomType -> AtomType -> RelationalError
AtomFunctionTypeError AttributeName
funcName' Int
argCount AtomType
expSubType AtomType
actSubType)
handler RelationalError
err = RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Relation
-> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType
verifyGraphRefAtomExprTypes Relation
relIn GraphRefAtomExpr
atomExpr AtomType
expectedType2 GraphRefRelationalExprM AtomType
-> (RelationalError -> GraphRefRelationalExprM AtomType)
-> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` RelationalError -> GraphRefRelationalExprM AtomType
handler
[AtomType]
funcArgTypes <- ((GraphRefAtomExpr, AtomType, Int)
-> GraphRefRelationalExprM AtomType)
-> [(GraphRefAtomExpr, AtomType, Int)]
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
[AtomType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GraphRefAtomExpr, AtomType, Int)
-> GraphRefRelationalExprM AtomType
funcArgVerifier ([(GraphRefAtomExpr, AtomType, Int)]
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
[AtomType])
-> [(GraphRefAtomExpr, AtomType, Int)]
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
[AtomType]
forall a b. (a -> b) -> a -> b
$ [GraphRefAtomExpr]
-> [AtomType] -> [Int] -> [(GraphRefAtomExpr, AtomType, Int)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [GraphRefAtomExpr]
funcArgExprs [AtomType]
expectedArgTypes [Int
1..]
if [AtomType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AtomType]
funcArgTypes Int -> Int -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= [AtomType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AtomType]
expectedArgTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then
RelationalError -> GraphRefRelationalExprM AtomType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([AtomType] -> [AtomType] -> RelationalError
AtomTypeCountError [AtomType]
funcArgTypes [AtomType]
expectedArgTypes)
else
ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expectedType ([AtomType] -> AtomType
forall a. [a] -> a
last [AtomType]
expectedArgTypes)
verifyGraphRefAtomExprTypes Relation
relIn (RelationAtomExpr GraphRefRelationalExpr
relationExpr) AtomType
expectedType =
do
let mergedAttrsEnv :: GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergedAttrsEnv = Attributes
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeAttributesIntoGraphRefRelationalExprEnv (Relation -> Attributes
attributes Relation
relIn)
Relation
relType <- (GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv)
-> GraphRefRelationalExprM Relation
-> GraphRefRelationalExprM Relation
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
R.local GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergedAttrsEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
relationExpr)
ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expectedType (Attributes -> AtomType
RelationAtomType (Relation -> Attributes
attributes Relation
relType))
verifyGraphRefAtomExprTypes Relation
rel cons :: GraphRefAtomExpr
cons@ConstructedAtomExpr{} AtomType
expectedType = do
AtomType
cType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr (Relation -> Attributes
attributes Relation
rel) GraphRefAtomExpr
cons
ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expectedType AtomType
cType
evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
evalGraphRefAttrExpr :: AttributeExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
evalGraphRefAttrExpr (AttributeAndTypeNameExpr AttributeName
attrName TypeConstructor
tCons GraphRefTransactionMarker
transId) = do
TypeConstructorMapping
tConsMap <- DatabaseContext -> TypeConstructorMapping
typeConstructorMapping (DatabaseContext -> TypeConstructorMapping)
-> GraphRefRelationalExprM DatabaseContext
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
TypeConstructorMapping
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
transId
AtomType
aType <- ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ DirtyFlag
-> TypeConstructor
-> TypeConstructorMapping
-> TypeVarMap
-> Either RelationalError AtomType
atomTypeForTypeConstructorValidate DirtyFlag
True TypeConstructor
tCons TypeConstructorMapping
tConsMap TypeVarMap
forall k a. Map k a
M.empty
ExceptT RelationalError Identity ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ())
-> ExceptT RelationalError Identity ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall a b. (a -> b) -> a -> b
$ Either RelationalError () -> ExceptT RelationalError Identity ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError () -> ExceptT RelationalError Identity ())
-> Either RelationalError () -> ExceptT RelationalError Identity ()
forall a b. (a -> b) -> a -> b
$ AtomType -> TypeConstructorMapping -> Either RelationalError ()
validateAtomType AtomType
aType TypeConstructorMapping
tConsMap
Attribute
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute)
-> Attribute
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
forall a b. (a -> b) -> a -> b
$ AttributeName -> AtomType -> Attribute
Attribute AttributeName
attrName AtomType
aType
evalGraphRefAttrExpr (NakedAttributeExpr Attribute
attr) = Attribute
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
attr
evalGraphRefTupleExprs :: Maybe Attributes -> GraphRefTupleExprs -> GraphRefRelationalExprM [RelationTuple]
evalGraphRefTupleExprs :: Maybe Attributes
-> GraphRefTupleExprs -> GraphRefRelationalExprM [RelationTuple]
evalGraphRefTupleExprs Maybe Attributes
_ (TupleExprs GraphRefTransactionMarker
_ []) = [RelationTuple] -> GraphRefRelationalExprM [RelationTuple]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
evalGraphRefTupleExprs Maybe Attributes
mAttrs (TupleExprs GraphRefTransactionMarker
fixedMarker [TupleExprBase GraphRefTransactionMarker]
tupleExprL) = do
[RelationTuple]
tuples <- (TupleExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
RelationTuple)
-> [TupleExprBase GraphRefTransactionMarker]
-> GraphRefRelationalExprM [RelationTuple]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe Attributes
-> TupleExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
RelationTuple
evalGraphRefTupleExpr Maybe Attributes
mAttrs) [TupleExprBase GraphRefTransactionMarker]
tupleExprL
Attributes
finalAttrs <- case Maybe Attributes
mAttrs of
Just Attributes
attrs -> Attributes
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attributes
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attributes
attrs
Maybe Attributes
Nothing ->
case [RelationTuple]
tuples of
[] -> Attributes
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attributes
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attributes
emptyAttributes
(RelationTuple
headTuple:[RelationTuple]
tailTuples) -> do
let
processTupleAttrs :: (Attribute, Attribute) -> t (ExceptT RelationalError m) Attribute
processTupleAttrs (Attribute
tupAttr, Attribute
accAttr) =
if Attribute -> DirtyFlag
isResolvedAttribute Attribute
accAttr DirtyFlag -> DirtyFlag -> DirtyFlag
&& Attribute
tupAttr Attribute -> Attribute -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== Attribute
accAttr then
Attribute -> t (ExceptT RelationalError m) Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
accAttr
else
ExceptT RelationalError m Attribute
-> t (ExceptT RelationalError m) Attribute
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError m Attribute
-> t (ExceptT RelationalError m) Attribute)
-> ExceptT RelationalError m Attribute
-> t (ExceptT RelationalError m) Attribute
forall a b. (a -> b) -> a -> b
$ Either RelationalError Attribute
-> ExceptT RelationalError m Attribute
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Attribute
-> ExceptT RelationalError m Attribute)
-> Either RelationalError Attribute
-> ExceptT RelationalError m Attribute
forall a b. (a -> b) -> a -> b
$ Attribute -> Attribute -> Either RelationalError Attribute
resolveAttributes Attribute
accAttr Attribute
tupAttr
[Attribute]
mostResolvedTypes <-
([Attribute]
-> RelationTuple -> GraphRefRelationalExprM [Attribute])
-> [Attribute]
-> [RelationTuple]
-> GraphRefRelationalExprM [Attribute]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[Attribute]
acc RelationTuple
tup -> do
let zipped :: [(Attribute, Attribute)]
zipped = [Attribute] -> [Attribute] -> [(Attribute, Attribute)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Vector Attribute -> [Attribute]
forall a. Vector a -> [a]
V.toList (Vector Attribute -> [Attribute])
-> (Attributes -> Vector Attribute) -> Attributes -> [Attribute]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> Vector Attribute
attributesVec (Attributes -> [Attribute]) -> Attributes -> [Attribute]
forall a b. (a -> b) -> a -> b
$ RelationTuple -> Attributes
tupleAttributes RelationTuple
tup) [Attribute]
acc
accNames :: Set AttributeName
accNames = [AttributeName] -> Set AttributeName
forall a. Ord a => [a] -> Set a
S.fromList ([AttributeName] -> Set AttributeName)
-> [AttributeName] -> Set AttributeName
forall a b. (a -> b) -> a -> b
$ (Attribute -> AttributeName) -> [Attribute] -> [AttributeName]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> AttributeName
A.attributeName [Attribute]
acc
tupNames :: Set AttributeName
tupNames = Attributes -> Set AttributeName
A.attributeNameSet (RelationTuple -> Attributes
tupleAttributes RelationTuple
tup)
attrNamesDiff :: Set AttributeName
attrNamesDiff = Set AttributeName -> Set AttributeName -> Set AttributeName
forall a. Ord a => Set a -> Set a -> Set a
S.union (Set AttributeName -> Set AttributeName -> Set AttributeName
forall a. Ord a => Set a -> Set a -> Set a
S.difference Set AttributeName
accNames Set AttributeName
tupNames) (Set AttributeName -> Set AttributeName -> Set AttributeName
forall a. Ord a => Set a -> Set a -> Set a
S.difference Set AttributeName
tupNames Set AttributeName
accNames)
DirtyFlag
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
unless (Set AttributeName -> DirtyFlag
forall (t :: * -> *) a. Foldable t => t a -> DirtyFlag
null Set AttributeName
attrNamesDiff) (RelationalError
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Set AttributeName -> RelationalError
AttributeNamesMismatchError Set AttributeName
attrNamesDiff))
[Attribute]
nextTupleAttrs <- ((Attribute, Attribute)
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute)
-> [(Attribute, Attribute)] -> GraphRefRelationalExprM [Attribute]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Attribute, Attribute)
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTrans t, Monad m,
Applicative (t (ExceptT RelationalError m))) =>
(Attribute, Attribute) -> t (ExceptT RelationalError m) Attribute
processTupleAttrs [(Attribute, Attribute)]
zipped
let diff :: Attributes
diff = Attributes -> Attributes -> Attributes
A.attributesDifference ([Attribute] -> Attributes
A.attributesFromList [Attribute]
nextTupleAttrs) ([Attribute] -> Attributes
A.attributesFromList [Attribute]
acc)
if Attributes
diff Attributes -> Attributes -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== Attributes
A.emptyAttributes then
[Attribute] -> GraphRefRelationalExprM [Attribute]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Attribute]
nextTupleAttrs
else
RelationalError -> GraphRefRelationalExprM [Attribute]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Attributes -> RelationalError
TupleAttributeTypeMismatchError Attributes
diff)
) (Vector Attribute -> [Attribute]
forall a. Vector a -> [a]
V.toList (Vector Attribute -> [Attribute])
-> (Attributes -> Vector Attribute) -> Attributes -> [Attribute]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> Vector Attribute
attributesVec (Attributes -> [Attribute]) -> Attributes -> [Attribute]
forall a b. (a -> b) -> a -> b
$ RelationTuple -> Attributes
tupleAttributes RelationTuple
headTuple) [RelationTuple]
tailTuples
Attributes
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attributes
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Attribute] -> Attributes
A.attributesFromList [Attribute]
mostResolvedTypes)
TypeConstructorMapping
tConsMap <- case [TupleExprBase GraphRefTransactionMarker] -> SingularTransactionRef
forall (f :: * -> *) (t :: * -> *).
(Foldable f, Foldable t) =>
f (t GraphRefTransactionMarker) -> SingularTransactionRef
singularTransactions [TupleExprBase GraphRefTransactionMarker]
tupleExprL of
SingularTransactionRef GraphRefTransactionMarker
commonTransId ->
DatabaseContext -> TypeConstructorMapping
typeConstructorMapping (DatabaseContext -> TypeConstructorMapping)
-> GraphRefRelationalExprM DatabaseContext
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
TypeConstructorMapping
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
commonTransId
SingularTransactionRef
NoTransactionsRef ->
DatabaseContext -> TypeConstructorMapping
typeConstructorMapping (DatabaseContext -> TypeConstructorMapping)
-> GraphRefRelationalExprM DatabaseContext
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
TypeConstructorMapping
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
fixedMarker
SingularTransactionRef
_ -> RelationalError
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
TypeConstructorMapping
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
TupleExprsReferenceMultipleMarkersError
ExceptT RelationalError Identity ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ())
-> ExceptT RelationalError Identity ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall a b. (a -> b) -> a -> b
$ Either RelationalError () -> ExceptT RelationalError Identity ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError () -> ExceptT RelationalError Identity ())
-> Either RelationalError () -> ExceptT RelationalError Identity ()
forall a b. (a -> b) -> a -> b
$ TypeConstructorMapping -> Attributes -> Either RelationalError ()
validateAttributes TypeConstructorMapping
tConsMap Attributes
finalAttrs
(RelationTuple
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
RelationTuple)
-> [RelationTuple] -> GraphRefRelationalExprM [RelationTuple]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ExceptT RelationalError Identity RelationTuple
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
RelationTuple
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity RelationTuple
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
RelationTuple)
-> (RelationTuple
-> ExceptT RelationalError Identity RelationTuple)
-> RelationTuple
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
RelationTuple
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either RelationalError RelationTuple
-> ExceptT RelationalError Identity RelationTuple
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError RelationTuple
-> ExceptT RelationalError Identity RelationTuple)
-> (RelationTuple -> Either RelationalError RelationTuple)
-> RelationTuple
-> ExceptT RelationalError Identity RelationTuple
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes
-> TypeConstructorMapping
-> RelationTuple
-> Either RelationalError RelationTuple
resolveTypesInTuple Attributes
finalAttrs TypeConstructorMapping
tConsMap) [RelationTuple]
tuples
evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple
evalGraphRefTupleExpr :: Maybe Attributes
-> TupleExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
RelationTuple
evalGraphRefTupleExpr Maybe Attributes
mAttrs (TupleExpr Map AttributeName GraphRefAtomExpr
tupMap) = do
let attrs :: Attributes
attrs = Attributes -> Maybe Attributes -> Attributes
forall a. a -> Maybe a -> a
fromMaybe Attributes
A.emptyAttributes Maybe Attributes
mAttrs
resolveOneAtom :: (AttributeName, GraphRefAtomExpr)
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(AttributeName, Atom, AtomType)
resolveOneAtom (AttributeName
attrName, GraphRefAtomExpr
aExpr) =
do
let eExpectedAtomType :: Either RelationalError AtomType
eExpectedAtomType = AttributeName -> Attributes -> Either RelationalError AtomType
A.atomTypeForAttributeName AttributeName
attrName Attributes
attrs
AtomType
unresolvedType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
attrs GraphRefAtomExpr
aExpr
AtomType
resolvedType <- case Either RelationalError AtomType
eExpectedAtomType of
Left RelationalError
_ -> AtomType -> GraphRefRelationalExprM AtomType
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomType
unresolvedType
Right AtomType
typeHint -> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType)
-> ExceptT RelationalError Identity AtomType
-> GraphRefRelationalExprM AtomType
forall a b. (a -> b) -> a -> b
$ Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType)
-> Either RelationalError AtomType
-> ExceptT RelationalError Identity AtomType
forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
resolveAtomType AtomType
typeHint AtomType
unresolvedType
Atom
newAtom <- RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
emptyTuple GraphRefAtomExpr
aExpr
(AttributeName, Atom, AtomType)
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(AttributeName, Atom, AtomType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AttributeName
attrName, Atom
newAtom, AtomType
resolvedType)
[(AttributeName, Atom, AtomType)]
attrAtoms <- ((AttributeName, GraphRefAtomExpr)
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(AttributeName, Atom, AtomType))
-> [(AttributeName, GraphRefAtomExpr)]
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
[(AttributeName, Atom, AtomType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AttributeName, GraphRefAtomExpr)
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(AttributeName, Atom, AtomType)
resolveOneAtom (Map AttributeName GraphRefAtomExpr
-> [(AttributeName, GraphRefAtomExpr)]
forall k a. Map k a -> [(k, a)]
M.toList Map AttributeName GraphRefAtomExpr
tupMap)
let tupAttrs :: Attributes
tupAttrs = [Attribute] -> Attributes
A.attributesFromList ([Attribute] -> Attributes) -> [Attribute] -> Attributes
forall a b. (a -> b) -> a -> b
$ ((AttributeName, Atom, AtomType) -> Attribute)
-> [(AttributeName, Atom, AtomType)] -> [Attribute]
forall a b. (a -> b) -> [a] -> [b]
map (\(AttributeName
attrName, Atom
_, AtomType
aType) -> AttributeName -> AtomType -> Attribute
Attribute AttributeName
attrName AtomType
aType) [(AttributeName, Atom, AtomType)]
attrAtoms
atoms :: Vector Atom
atoms = [Atom] -> Vector Atom
forall a. [a] -> Vector a
V.fromList ([Atom] -> Vector Atom) -> [Atom] -> Vector Atom
forall a b. (a -> b) -> a -> b
$ ((AttributeName, Atom, AtomType) -> Atom)
-> [(AttributeName, Atom, AtomType)] -> [Atom]
forall a b. (a -> b) -> [a] -> [b]
map (\(AttributeName
_, Atom
atom, AtomType
_) -> Atom
atom) [(AttributeName, Atom, AtomType)]
attrAtoms
tup :: RelationTuple
tup = Attributes -> Vector Atom -> RelationTuple
mkRelationTuple Attributes
tupAttrs Vector Atom
atoms
finalAttrs :: Attributes
finalAttrs = Attributes -> Maybe Attributes -> Attributes
forall a. a -> Maybe a -> a
fromMaybe Attributes
tupAttrs Maybe Attributes
mAttrs
DirtyFlag
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
when (Attributes -> Set AttributeName
A.attributeNameSet Attributes
finalAttrs Set AttributeName -> Set AttributeName -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
/= Attributes -> Set AttributeName
A.attributeNameSet Attributes
tupAttrs) (ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ())
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall a b. (a -> b) -> a -> b
$ RelationalError
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Attributes -> RelationalError
TupleAttributeTypeMismatchError Attributes
tupAttrs)
let tup' :: RelationTuple
tup' = Attributes -> RelationTuple -> RelationTuple
reorderTuple Attributes
finalAttrs RelationTuple
tup
RelationTuple
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
RelationTuple
forall (f :: * -> *) a. Applicative f => a -> f a
pure RelationTuple
tup'
evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr (MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrExprs GraphRefTupleExprs
tupleExprs) = do
Maybe Attributes
mAttrs <- case Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrExprs of
Just [AttributeExprBase GraphRefTransactionMarker]
_ ->
Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just (Attributes -> Maybe Attributes)
-> ([Attribute] -> Attributes) -> [Attribute] -> Maybe Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attribute] -> Attributes
A.attributesFromList ([Attribute] -> Maybe Attributes)
-> GraphRefRelationalExprM [Attribute]
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(Maybe Attributes)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AttributeExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute)
-> [AttributeExprBase GraphRefTransactionMarker]
-> GraphRefRelationalExprM [Attribute]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AttributeExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
evalGraphRefAttrExpr ([AttributeExprBase GraphRefTransactionMarker]
-> Maybe [AttributeExprBase GraphRefTransactionMarker]
-> [AttributeExprBase GraphRefTransactionMarker]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrExprs)
Maybe [AttributeExprBase GraphRefTransactionMarker]
Nothing -> Maybe Attributes
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(Maybe Attributes)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attributes
forall a. Maybe a
Nothing
[RelationTuple]
tuples <- Maybe Attributes
-> GraphRefTupleExprs -> GraphRefRelationalExprM [RelationTuple]
evalGraphRefTupleExprs Maybe Attributes
mAttrs GraphRefTupleExprs
tupleExprs
let attrs :: Attributes
attrs = Attributes -> Maybe Attributes -> Attributes
forall a. a -> Maybe a -> a
fromMaybe Attributes
firstTupleAttrs Maybe Attributes
mAttrs
firstTupleAttrs :: Attributes
firstTupleAttrs = if [RelationTuple] -> DirtyFlag
forall (t :: * -> *) a. Foldable t => t a -> DirtyFlag
null [RelationTuple]
tuples then Attributes
A.emptyAttributes else RelationTuple -> Attributes
tupleAttributes ([RelationTuple] -> RelationTuple
forall a. [a] -> a
head [RelationTuple]
tuples)
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation Attributes
attrs ([RelationTuple] -> RelationTupleSet
RelationTupleSet [RelationTuple]
tuples)
evalGraphRefRelationalExpr (MakeStaticRelation Attributes
attributeSet RelationTupleSet
tupleSet) =
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation Attributes
attributeSet RelationTupleSet
tupleSet
evalGraphRefRelationalExpr (ExistingRelation Relation
rel) = Relation -> GraphRefRelationalExprM Relation
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
rel
evalGraphRefRelationalExpr (RelationVariable AttributeName
name GraphRefTransactionMarker
tid) = do
DatabaseContext
ctx <- GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
tid
case AttributeName
-> Map AttributeName GraphRefRelationalExpr
-> Maybe GraphRefRelationalExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
name (DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables DatabaseContext
ctx) of
Maybe GraphRefRelationalExpr
Nothing -> RelationalError -> GraphRefRelationalExprM Relation
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AttributeName -> RelationalError
RelVarNotDefinedError AttributeName
name)
Just GraphRefRelationalExpr
rv -> GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
rv
evalGraphRefRelationalExpr (Project AttributeNamesBase GraphRefTransactionMarker
attrNames GraphRefRelationalExpr
expr) = do
Set AttributeName
attrNameSet <- AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM (Set AttributeName)
evalGraphRefAttributeNames AttributeNamesBase GraphRefTransactionMarker
attrNames GraphRefRelationalExpr
expr
Relation
rel <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
expr
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Set AttributeName -> Relation -> Either RelationalError Relation
project Set AttributeName
attrNameSet Relation
rel
evalGraphRefRelationalExpr (Union GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = do
Relation
relA <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
exprA
Relation
relB <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
exprB
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Relation -> Relation -> Either RelationalError Relation
union Relation
relA Relation
relB
evalGraphRefRelationalExpr (Join GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = do
Relation
relA <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
exprA
Relation
relB <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
exprB
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Relation -> Relation -> Either RelationalError Relation
join Relation
relA Relation
relB
evalGraphRefRelationalExpr (Rename AttributeName
oldName AttributeName
newName GraphRefRelationalExpr
expr) = do
Relation
rel <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
expr
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ AttributeName
-> AttributeName -> Relation -> Either RelationalError Relation
rename AttributeName
oldName AttributeName
newName Relation
rel
evalGraphRefRelationalExpr (Difference GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = do
Relation
relA <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
exprA
Relation
relB <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
exprB
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Relation -> Relation -> Either RelationalError Relation
difference Relation
relA Relation
relB
evalGraphRefRelationalExpr (Group AttributeNamesBase GraphRefTransactionMarker
groupAttrNames AttributeName
newAttrName GraphRefRelationalExpr
expr) = do
Set AttributeName
groupNames <- AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM (Set AttributeName)
evalGraphRefAttributeNames AttributeNamesBase GraphRefTransactionMarker
groupAttrNames GraphRefRelationalExpr
expr
Relation
rel <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
expr
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Set AttributeName
-> AttributeName -> Relation -> Either RelationalError Relation
group Set AttributeName
groupNames AttributeName
newAttrName Relation
rel
evalGraphRefRelationalExpr (Ungroup AttributeName
groupAttrName GraphRefRelationalExpr
expr) = do
Relation
rel <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
expr
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ AttributeName -> Relation -> Either RelationalError Relation
ungroup AttributeName
groupAttrName Relation
rel
evalGraphRefRelationalExpr (Restrict RestrictionPredicateExprBase GraphRefTransactionMarker
predExpr GraphRefRelationalExpr
expr) = do
Relation
rel <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
expr
RestrictionFilter
filt <- Attributes
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter (Relation -> Attributes
attributes Relation
rel) RestrictionPredicateExprBase GraphRefTransactionMarker
predExpr
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ RestrictionFilter -> Relation -> Either RelationalError Relation
restrict RestrictionFilter
filt Relation
rel
evalGraphRefRelationalExpr (Equals GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = do
Relation
relA <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
exprA
Relation
relB <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
exprB
Relation -> GraphRefRelationalExprM Relation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Relation -> GraphRefRelationalExprM Relation)
-> Relation -> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ if Relation
relA Relation -> Relation -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== Relation
relB then Relation
relationTrue else Relation
relationFalse
evalGraphRefRelationalExpr (NotEquals GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = do
Relation
relA <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
exprA
Relation
relB <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
exprB
Relation -> GraphRefRelationalExprM Relation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Relation -> GraphRefRelationalExprM Relation)
-> Relation -> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ if Relation
relA Relation -> Relation -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== Relation
relB then Relation
relationFalse else Relation
relationTrue
evalGraphRefRelationalExpr (Extend GraphRefExtendTupleExpr
extendTupleExpr GraphRefRelationalExpr
expr) = do
Relation
rel <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
expr
(Attributes
newAttrs, RelationTuple -> Either RelationalError RelationTuple
tupProc) <- Relation
-> GraphRefExtendTupleExpr
-> GraphRefRelationalExprM
(Attributes, RelationTuple -> Either RelationalError RelationTuple)
extendGraphRefTupleExpressionProcessor Relation
rel GraphRefExtendTupleExpr
extendTupleExpr
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ (RelationTuple -> Either RelationalError RelationTuple)
-> Attributes -> Relation -> Either RelationalError Relation
relMogrify RelationTuple -> Either RelationalError RelationTuple
tupProc Attributes
newAttrs Relation
rel
evalGraphRefRelationalExpr expr :: GraphRefRelationalExpr
expr@With{} =
GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr (WithNameAssocs -> GraphRefRelationalExpr -> GraphRefRelationalExpr
substituteWithNameMacros [] GraphRefRelationalExpr
expr)
dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext
dbContextForTransId :: TransactionId
-> TransactionGraph -> Either RelationalError DatabaseContext
dbContextForTransId TransactionId
tid TransactionGraph
graph = do
Transaction
trans <- TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
tid TransactionGraph
graph
DatabaseContext -> Either RelationalError DatabaseContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transaction -> DatabaseContext
concreteDatabaseContext Transaction
trans)
transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
transactionForId :: TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
tid TransactionGraph
graph
| TransactionId
tid TransactionId -> TransactionId -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== TransactionId
U.nil =
RelationalError -> Either RelationalError Transaction
forall a b. a -> Either a b
Left RelationalError
RootTransactionTraversalError
| Set Transaction -> DirtyFlag
forall a. Set a -> DirtyFlag
S.null Set Transaction
matchingTrans =
RelationalError -> Either RelationalError Transaction
forall a b. a -> Either a b
Left (RelationalError -> Either RelationalError Transaction)
-> RelationalError -> Either RelationalError Transaction
forall a b. (a -> b) -> a -> b
$ TransactionId -> RelationalError
NoSuchTransactionError TransactionId
tid
| DirtyFlag
otherwise =
Transaction -> Either RelationalError Transaction
forall a b. b -> Either a b
Right (Transaction -> Either RelationalError Transaction)
-> Transaction -> Either RelationalError Transaction
forall a b. (a -> b) -> a -> b
$ [Transaction] -> Transaction
forall a. [a] -> a
head (Set Transaction -> [Transaction]
forall a. Set a -> [a]
S.toList Set Transaction
matchingTrans)
where
matchingTrans :: Set Transaction
matchingTrans = (Transaction -> DirtyFlag) -> Set Transaction -> Set Transaction
forall a. (a -> DirtyFlag) -> Set a -> Set a
S.filter (\(Transaction TransactionId
idMatch TransactionInfo
_ Schemas
_) -> TransactionId
idMatch TransactionId -> TransactionId -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== TransactionId
tid) (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graph)
typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr (MakeStaticRelation Attributes
attrs RelationTupleSet
_) = ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation Attributes
attrs RelationTupleSet
emptyTupleSet
typeForGraphRefRelationalExpr (ExistingRelation Relation
rel) = Relation -> GraphRefRelationalExprM Relation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes -> Relation
emptyRelationWithAttrs (Relation -> Attributes
attributes Relation
rel))
typeForGraphRefRelationalExpr (MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrExprs GraphRefTupleExprs
tupleExprs) = do
Maybe Attributes
mAttrs <- case Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrExprs of
Just [AttributeExprBase GraphRefTransactionMarker]
attrExprs -> do
[Attribute]
attrs <- (AttributeExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute)
-> [AttributeExprBase GraphRefTransactionMarker]
-> GraphRefRelationalExprM [Attribute]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AttributeExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
evalGraphRefAttributeExpr [AttributeExprBase GraphRefTransactionMarker]
attrExprs
Maybe Attributes
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(Maybe Attributes)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just ([Attribute] -> Attributes
attributesFromList [Attribute]
attrs))
Maybe [AttributeExprBase GraphRefTransactionMarker]
Nothing -> Maybe Attributes
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(Maybe Attributes)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attributes
forall a. Maybe a
Nothing
[RelationTuple]
tuples <- Maybe Attributes
-> GraphRefTupleExprs -> GraphRefRelationalExprM [RelationTuple]
evalGraphRefTupleExprs Maybe Attributes
mAttrs GraphRefTupleExprs
tupleExprs
let retAttrs :: Attributes
retAttrs = case [RelationTuple]
tuples of
(RelationTuple
tup:[RelationTuple]
_) -> RelationTuple -> Attributes
tupleAttributes RelationTuple
tup
[] -> Attributes -> Maybe Attributes -> Attributes
forall a. a -> Maybe a -> a
fromMaybe Attributes
A.emptyAttributes Maybe Attributes
mAttrs
Relation -> GraphRefRelationalExprM Relation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Relation -> GraphRefRelationalExprM Relation)
-> Relation -> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Attributes -> Relation
emptyRelationWithAttrs Attributes
retAttrs
typeForGraphRefRelationalExpr (RelationVariable AttributeName
rvName GraphRefTransactionMarker
tid) = do
Map AttributeName GraphRefRelationalExpr
relVars <- DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables (DatabaseContext -> Map AttributeName GraphRefRelationalExpr)
-> GraphRefRelationalExprM DatabaseContext
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(Map AttributeName GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
tid
case AttributeName
-> Map AttributeName GraphRefRelationalExpr
-> Maybe GraphRefRelationalExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
rvName Map AttributeName GraphRefRelationalExpr
relVars of
Maybe GraphRefRelationalExpr
Nothing -> RelationalError -> GraphRefRelationalExprM Relation
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AttributeName -> RelationalError
RelVarNotDefinedError AttributeName
rvName)
Just GraphRefRelationalExpr
rvExpr ->
GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
rvExpr
typeForGraphRefRelationalExpr (Project AttributeNamesBase GraphRefTransactionMarker
attrNames GraphRefRelationalExpr
expr) = do
Relation
exprType' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
expr
Set AttributeName
projectionAttrs <- AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM (Set AttributeName)
evalGraphRefAttributeNames AttributeNamesBase GraphRefTransactionMarker
attrNames GraphRefRelationalExpr
expr
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Set AttributeName -> Relation -> Either RelationalError Relation
project Set AttributeName
projectionAttrs Relation
exprType'
typeForGraphRefRelationalExpr (Union GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = do
Relation
exprA' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
exprA
Relation
exprB' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
exprB
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Relation -> Relation -> Either RelationalError Relation
union Relation
exprA' Relation
exprB'
typeForGraphRefRelationalExpr (Join GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = do
Relation
exprA' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
exprA
Relation
exprB' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
exprB
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Relation -> Relation -> Either RelationalError Relation
join Relation
exprA' Relation
exprB'
typeForGraphRefRelationalExpr (Rename AttributeName
oldAttr AttributeName
newAttr GraphRefRelationalExpr
expr) = do
Relation
expr' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
expr
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ AttributeName
-> AttributeName -> Relation -> Either RelationalError Relation
rename AttributeName
oldAttr AttributeName
newAttr Relation
expr'
typeForGraphRefRelationalExpr (Difference GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = do
Relation
exprA' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
exprA
Relation
exprB' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
exprB
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Relation -> Relation -> Either RelationalError Relation
difference Relation
exprA' Relation
exprB'
typeForGraphRefRelationalExpr (Group AttributeNamesBase GraphRefTransactionMarker
groupNames AttributeName
attrName GraphRefRelationalExpr
expr) = do
Relation
expr' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
expr
Set AttributeName
groupNames' <- AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM (Set AttributeName)
evalGraphRefAttributeNames AttributeNamesBase GraphRefTransactionMarker
groupNames GraphRefRelationalExpr
expr
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ Set AttributeName
-> AttributeName -> Relation -> Either RelationalError Relation
group Set AttributeName
groupNames' AttributeName
attrName Relation
expr'
typeForGraphRefRelationalExpr (Ungroup AttributeName
groupAttrName GraphRefRelationalExpr
expr) = do
Relation
expr' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
expr
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ AttributeName -> Relation -> Either RelationalError Relation
ungroup AttributeName
groupAttrName Relation
expr'
typeForGraphRefRelationalExpr (Restrict RestrictionPredicateExprBase GraphRefTransactionMarker
pred' GraphRefRelationalExpr
expr) = do
Relation
expr' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
expr
RestrictionFilter
filt <- Attributes
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM RestrictionFilter
predicateRestrictionFilter (Relation -> Attributes
attributes Relation
expr') RestrictionPredicateExprBase GraphRefTransactionMarker
pred'
ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation)
-> ExceptT RelationalError Identity Relation
-> GraphRefRelationalExprM Relation
forall a b. (a -> b) -> a -> b
$ Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError Relation
-> ExceptT RelationalError Identity Relation)
-> Either RelationalError Relation
-> ExceptT RelationalError Identity Relation
forall a b. (a -> b) -> a -> b
$ RestrictionFilter -> Relation -> Either RelationalError Relation
restrict RestrictionFilter
filt Relation
expr'
typeForGraphRefRelationalExpr Equals{} =
Relation -> GraphRefRelationalExprM Relation
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
relationFalse
typeForGraphRefRelationalExpr NotEquals{} =
Relation -> GraphRefRelationalExprM Relation
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
relationFalse
typeForGraphRefRelationalExpr (Extend GraphRefExtendTupleExpr
extendTupleExpr GraphRefRelationalExpr
expr) = do
Relation
rel <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
expr
GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr (GraphRefExtendTupleExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Extend GraphRefExtendTupleExpr
extendTupleExpr (Relation -> GraphRefRelationalExpr
forall a. Relation -> RelationalExprBase a
ExistingRelation Relation
rel))
typeForGraphRefRelationalExpr expr :: GraphRefRelationalExpr
expr@(With WithNameAssocs
withs GraphRefRelationalExpr
_) = do
let expr' :: GraphRefRelationalExpr
expr' = WithNameAssocs -> GraphRefRelationalExpr -> GraphRefRelationalExpr
substituteWithNameMacros [] GraphRefRelationalExpr
expr
checkMacroName :: WithNameExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
checkMacroName (WithNameExpr AttributeName
macroName GraphRefTransactionMarker
tid) = do
Map AttributeName GraphRefRelationalExpr
rvs <- DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables (DatabaseContext -> Map AttributeName GraphRefRelationalExpr)
-> GraphRefRelationalExprM DatabaseContext
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
(Map AttributeName GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
tid
case AttributeName
-> Map AttributeName GraphRefRelationalExpr
-> Maybe GraphRefRelationalExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
macroName Map AttributeName GraphRefRelationalExpr
rvs of
Just GraphRefRelationalExpr
_ -> ExceptT RelationalError Identity ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT RelationalError Identity ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ())
-> ExceptT RelationalError Identity ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall a b. (a -> b) -> a -> b
$ Either RelationalError () -> ExceptT RelationalError Identity ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either RelationalError () -> ExceptT RelationalError Identity ())
-> Either RelationalError () -> ExceptT RelationalError Identity ()
forall a b. (a -> b) -> a -> b
$ RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left (AttributeName -> RelationalError
RelVarAlreadyDefinedError AttributeName
macroName)
Maybe GraphRefRelationalExpr
Nothing -> ()
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
((WithNameExprBase GraphRefTransactionMarker,
GraphRefRelationalExpr)
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ())
-> WithNameAssocs
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WithNameExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
checkMacroName (WithNameExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ())
-> ((WithNameExprBase GraphRefTransactionMarker,
GraphRefRelationalExpr)
-> WithNameExprBase GraphRefTransactionMarker)
-> (WithNameExprBase GraphRefTransactionMarker,
GraphRefRelationalExpr)
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithNameExprBase GraphRefTransactionMarker,
GraphRefRelationalExpr)
-> WithNameExprBase GraphRefTransactionMarker
forall a b. (a, b) -> a
fst) WithNameAssocs
withs
GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
expr'
evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)
evalGraphRefAttributeNames :: AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM (Set AttributeName)
evalGraphRefAttributeNames AttributeNamesBase GraphRefTransactionMarker
attrNames GraphRefRelationalExpr
expr = do
Relation
exprType' <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
expr
let typeNameSet :: Set AttributeName
typeNameSet = [AttributeName] -> Set AttributeName
forall a. Ord a => [a] -> Set a
S.fromList (Vector AttributeName -> [AttributeName]
forall a. Vector a -> [a]
V.toList (Attributes -> Vector AttributeName
A.attributeNames (Relation -> Attributes
attributes Relation
exprType')))
case AttributeNamesBase GraphRefTransactionMarker
attrNames of
AttributeNames Set AttributeName
names ->
case Set AttributeName
-> Attributes -> Either RelationalError Attributes
A.projectionAttributesForNames Set AttributeName
names (Relation -> Attributes
attributes Relation
exprType') of
Left RelationalError
err -> RelationalError -> GraphRefRelationalExprM (Set AttributeName)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right Attributes
attrs -> Set AttributeName -> GraphRefRelationalExprM (Set AttributeName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([AttributeName] -> Set AttributeName
forall a. Ord a => [a] -> Set a
S.fromList (Vector AttributeName -> [AttributeName]
forall a. Vector a -> [a]
V.toList (Attributes -> Vector AttributeName
A.attributeNames Attributes
attrs)))
InvertedAttributeNames Set AttributeName
names -> do
let nonExistentAttributeNames :: Set AttributeName
nonExistentAttributeNames = Set AttributeName -> Set AttributeName -> Set AttributeName
A.attributeNamesNotContained Set AttributeName
names Set AttributeName
typeNameSet
if DirtyFlag -> DirtyFlag
not (Set AttributeName -> DirtyFlag
forall a. Set a -> DirtyFlag
S.null Set AttributeName
nonExistentAttributeNames) then
RelationalError -> GraphRefRelationalExprM (Set AttributeName)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RelationalError -> GraphRefRelationalExprM (Set AttributeName))
-> RelationalError -> GraphRefRelationalExprM (Set AttributeName)
forall a b. (a -> b) -> a -> b
$ Set AttributeName -> RelationalError
AttributeNamesMismatchError Set AttributeName
nonExistentAttributeNames
else
Set AttributeName -> GraphRefRelationalExprM (Set AttributeName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set AttributeName -> Set AttributeName -> Set AttributeName
A.nonMatchingAttributeNameSet Set AttributeName
names Set AttributeName
typeNameSet)
UnionAttributeNames AttributeNamesBase GraphRefTransactionMarker
namesA AttributeNamesBase GraphRefTransactionMarker
namesB -> do
Set AttributeName
nameSetA <- AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM (Set AttributeName)
evalGraphRefAttributeNames AttributeNamesBase GraphRefTransactionMarker
namesA GraphRefRelationalExpr
expr
Set AttributeName
nameSetB <- AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM (Set AttributeName)
evalGraphRefAttributeNames AttributeNamesBase GraphRefTransactionMarker
namesB GraphRefRelationalExpr
expr
Set AttributeName -> GraphRefRelationalExprM (Set AttributeName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set AttributeName -> Set AttributeName -> Set AttributeName
forall a. Ord a => Set a -> Set a -> Set a
S.union Set AttributeName
nameSetA Set AttributeName
nameSetB)
IntersectAttributeNames AttributeNamesBase GraphRefTransactionMarker
namesA AttributeNamesBase GraphRefTransactionMarker
namesB -> do
Set AttributeName
nameSetA <- AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM (Set AttributeName)
evalGraphRefAttributeNames AttributeNamesBase GraphRefTransactionMarker
namesA GraphRefRelationalExpr
expr
Set AttributeName
nameSetB <- AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr
-> GraphRefRelationalExprM (Set AttributeName)
evalGraphRefAttributeNames AttributeNamesBase GraphRefTransactionMarker
namesB GraphRefRelationalExpr
expr
Set AttributeName -> GraphRefRelationalExprM (Set AttributeName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set AttributeName -> Set AttributeName -> Set AttributeName
forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set AttributeName
nameSetA Set AttributeName
nameSetB)
RelationalExprAttributeNames GraphRefRelationalExpr
attrExpr -> do
Relation
attrExprType <- GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
attrExpr
Set AttributeName -> GraphRefRelationalExprM (Set AttributeName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes -> Set AttributeName
A.attributeNameSet (Relation -> Attributes
attributes Relation
attrExprType))
evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
evalGraphRefAttributeExpr :: AttributeExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
evalGraphRefAttributeExpr (AttributeAndTypeNameExpr AttributeName
attrName TypeConstructor
tCons GraphRefTransactionMarker
tid) = do
TypeConstructorMapping
tConsMap <- DatabaseContext -> TypeConstructorMapping
typeConstructorMapping (DatabaseContext -> TypeConstructorMapping)
-> GraphRefRelationalExprM DatabaseContext
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
TypeConstructorMapping
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
tid
case DirtyFlag
-> TypeConstructor
-> TypeConstructorMapping
-> TypeVarMap
-> Either RelationalError AtomType
atomTypeForTypeConstructorValidate DirtyFlag
True TypeConstructor
tCons TypeConstructorMapping
tConsMap TypeVarMap
forall k a. Map k a
M.empty of
Left RelationalError
err -> RelationalError
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right AtomType
aType -> do
case AtomType -> TypeConstructorMapping -> Either RelationalError ()
validateAtomType AtomType
aType TypeConstructorMapping
tConsMap of
Left RelationalError
err -> RelationalError
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right ()
_ -> Attribute
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AttributeName -> AtomType -> Attribute
Attribute AttributeName
attrName AtomType
aType)
evalGraphRefAttributeExpr (NakedAttributeExpr Attribute
attr) = Attribute
-> ReaderT
GraphRefRelationalExprEnv
(ExceptT RelationalError Identity)
Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
attr
mkEmptyRelVars :: RelationVariables -> RelationVariables
mkEmptyRelVars :: Map AttributeName GraphRefRelationalExpr
-> Map AttributeName GraphRefRelationalExpr
mkEmptyRelVars = (GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> Map AttributeName GraphRefRelationalExpr
-> Map AttributeName GraphRefRelationalExpr
forall a b k. (a -> b) -> Map k a -> Map k b
M.map GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a. RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar
where
mkEmptyRelVar :: RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar expr :: RelationalExprBase a
expr@MakeRelationFromExprs{} = RelationalExprBase a
expr
mkEmptyRelVar (MakeStaticRelation Attributes
attrs RelationTupleSet
_) = Attributes -> RelationTupleSet -> RelationalExprBase a
forall a. Attributes -> RelationTupleSet -> RelationalExprBase a
MakeStaticRelation Attributes
attrs RelationTupleSet
emptyTupleSet
mkEmptyRelVar (ExistingRelation Relation
rel) = Relation -> RelationalExprBase a
forall a. Relation -> RelationalExprBase a
ExistingRelation (Attributes -> Relation
emptyRelationWithAttrs (Relation -> Attributes
attributes Relation
rel))
mkEmptyRelVar rv :: RelationalExprBase a
rv@RelationVariable{} = RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExprBase a
forall a. RestrictionPredicateExprBase a
TruePredicate) RelationalExprBase a
rv
mkEmptyRelVar (Project AttributeNamesBase a
attrNames RelationalExprBase a
expr) = AttributeNamesBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
AttributeNamesBase a
-> RelationalExprBase a -> RelationalExprBase a
Project AttributeNamesBase a
attrNames (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
expr)
mkEmptyRelVar (Union RelationalExprBase a
exprA RelationalExprBase a
exprB) = RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
exprA) (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
exprB)
mkEmptyRelVar (Join RelationalExprBase a
exprA RelationalExprBase a
exprB) = RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Join (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
exprA) (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
exprB)
mkEmptyRelVar (Rename AttributeName
nameA AttributeName
nameB RelationalExprBase a
expr) = AttributeName
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
forall a.
AttributeName
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
Rename AttributeName
nameA AttributeName
nameB (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
expr)
mkEmptyRelVar (Difference RelationalExprBase a
exprA RelationalExprBase a
exprB) = RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Difference (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
exprA) (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
exprB)
mkEmptyRelVar (Group AttributeNamesBase a
attrNames AttributeName
attrName RelationalExprBase a
expr) = AttributeNamesBase a
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
forall a.
AttributeNamesBase a
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
Group AttributeNamesBase a
attrNames AttributeName
attrName (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
expr)
mkEmptyRelVar (Ungroup AttributeName
attrName RelationalExprBase a
expr) = AttributeName -> RelationalExprBase a -> RelationalExprBase a
forall a.
AttributeName -> RelationalExprBase a -> RelationalExprBase a
Ungroup AttributeName
attrName (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
expr)
mkEmptyRelVar (Restrict RestrictionPredicateExprBase a
pred' RelationalExprBase a
expr) = RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict RestrictionPredicateExprBase a
pred' (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
expr)
mkEmptyRelVar (Equals RelationalExprBase a
exprA RelationalExprBase a
exprB) = RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Equals (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
exprA) (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
exprB)
mkEmptyRelVar (NotEquals RelationalExprBase a
exprA RelationalExprBase a
exprB) = RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
NotEquals (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
exprA) (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
exprB)
mkEmptyRelVar (Extend ExtendTupleExprBase a
extTuple RelationalExprBase a
expr) = ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
forall a.
ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Extend ExtendTupleExprBase a
extTuple (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
expr)
mkEmptyRelVar (With [(WithNameExprBase a, RelationalExprBase a)]
macros RelationalExprBase a
expr) = [(WithNameExprBase a, RelationalExprBase a)]
-> RelationalExprBase a -> RelationalExprBase a
forall a.
[(WithNameExprBase a, RelationalExprBase a)]
-> RelationalExprBase a -> RelationalExprBase a
With (((WithNameExprBase a, RelationalExprBase a)
-> (WithNameExprBase a, RelationalExprBase a))
-> [(WithNameExprBase a, RelationalExprBase a)]
-> [(WithNameExprBase a, RelationalExprBase a)]
forall a b. (a -> b) -> [a] -> [b]
map ((RelationalExprBase a -> RelationalExprBase a)
-> (WithNameExprBase a, RelationalExprBase a)
-> (WithNameExprBase a, RelationalExprBase a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar) [(WithNameExprBase a, RelationalExprBase a)]
macros) (RelationalExprBase a -> RelationalExprBase a
mkEmptyRelVar RelationalExprBase a
expr)
dbErr :: RelationalError -> DatabaseContextEvalMonad ()
dbErr :: RelationalError -> DatabaseContextEvalMonad ()
dbErr RelationalError
err = ExceptT RelationalError Identity () -> DatabaseContextEvalMonad ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either RelationalError () -> ExceptT RelationalError Identity ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (RelationalError -> Either RelationalError ()
forall a b. a -> Either a b
Left RelationalError
err))
relationVariablesAsRelation :: DatabaseContext -> TransactionGraph -> Either RelationalError Relation
relationVariablesAsRelation :: DatabaseContext
-> TransactionGraph -> Either RelationalError Relation
relationVariablesAsRelation DatabaseContext
ctx TransactionGraph
graph = do
let subrelAttrs :: Attributes
subrelAttrs = [Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
"attribute" AtomType
TextAtomType, AttributeName -> AtomType -> Attribute
Attribute AttributeName
"type" AtomType
TextAtomType]
attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
"name" AtomType
TextAtomType,
AttributeName -> AtomType -> Attribute
Attribute AttributeName
"attributes" (Attributes -> AtomType
RelationAtomType Attributes
subrelAttrs)]
relVars :: Map AttributeName GraphRefRelationalExpr
relVars = DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables DatabaseContext
ctx
mkRvDesc :: (a, GraphRefRelationalExpr) -> Either RelationalError (a, Relation)
mkRvDesc (a
rvName, GraphRefRelationalExpr
gfExpr) = do
let gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (DatabaseContext -> Maybe DatabaseContext
forall a. a -> Maybe a
Just DatabaseContext
ctx) TransactionGraph
graph
Relation
gfType <- GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfExpr)
(a, Relation) -> Either RelationalError (a, Relation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
rvName, Relation
gfType)
relVarToAtomList :: (AttributeName, Relation) -> [Atom]
relVarToAtomList (AttributeName
rvName, Relation
rel) = [AttributeName -> Atom
TextAtom AttributeName
rvName, Vector Attribute -> Atom
attributesToRel (Attributes -> Vector Attribute
attributesVec (Relation -> Attributes
attributes Relation
rel))]
attrAtoms :: Attribute -> [Atom]
attrAtoms Attribute
a = [AttributeName -> Atom
TextAtom (Attribute -> AttributeName
A.attributeName Attribute
a), AttributeName -> Atom
TextAtom (AtomType -> AttributeName
prettyAtomType (Attribute -> AtomType
A.atomType Attribute
a))]
attributesToRel :: Vector Attribute -> Atom
attributesToRel Vector Attribute
attrl = case Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList Attributes
subrelAttrs ((Attribute -> [Atom]) -> [Attribute] -> [[Atom]]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> [Atom]
attrAtoms (Vector Attribute -> [Attribute]
forall a. Vector a -> [a]
V.toList Vector Attribute
attrl)) of
Left RelationalError
err -> [Char] -> Atom
forall a. HasCallStack => [Char] -> a
error ([Char]
"relationVariablesAsRelation pooped " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RelationalError -> [Char]
forall a. Show a => a -> [Char]
show RelationalError
err)
Right Relation
rel -> Relation -> Atom
RelationAtom Relation
rel
[(AttributeName, Relation)]
rvs <- ((AttributeName, GraphRefRelationalExpr)
-> Either RelationalError (AttributeName, Relation))
-> [(AttributeName, GraphRefRelationalExpr)]
-> Either RelationalError [(AttributeName, Relation)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AttributeName, GraphRefRelationalExpr)
-> Either RelationalError (AttributeName, Relation)
forall a.
(a, GraphRefRelationalExpr) -> Either RelationalError (a, Relation)
mkRvDesc (Map AttributeName GraphRefRelationalExpr
-> [(AttributeName, GraphRefRelationalExpr)]
forall k a. Map k a -> [(k, a)]
M.toList Map AttributeName GraphRefRelationalExpr
relVars)
let tups :: [[Atom]]
tups = ((AttributeName, Relation) -> [Atom])
-> [(AttributeName, Relation)] -> [[Atom]]
forall a b. (a -> b) -> [a] -> [b]
map (AttributeName, Relation) -> [Atom]
relVarToAtomList [(AttributeName, Relation)]
rvs
Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList Attributes
attrs [[Atom]]
tups
evalRelationalExpr :: RelationalExpr -> RelationalExprM Relation
evalRelationalExpr :: RelationalExpr -> RelationalExprM Relation
evalRelationalExpr RelationalExpr
expr = do
TransactionGraph
graph <- RelationalExprM TransactionGraph
reGraph
DatabaseContext
context <- RelationalExprM DatabaseContext
reContext
let expr' :: GraphRefRelationalExpr
expr' = GraphRefTransactionMarker
-> ProcessExprM GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a. GraphRefTransactionMarker -> ProcessExprM a -> a
runProcessExprM GraphRefTransactionMarker
UncommittedContextMarker (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
expr)
gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (DatabaseContext -> Maybe DatabaseContext
forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
case GraphRefRelationalExprEnv
-> GraphRefRelationalExprM Relation
-> Either RelationalError Relation
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
expr') of
Left RelationalError
err -> RelationalError -> RelationalExprM Relation
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right Relation
rel -> Relation -> RelationalExprM Relation
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
rel
class (MonadError RelationalError m, Monad m) => DatabaseContextM m where
getContext :: m DatabaseContext
instance DatabaseContextM (ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity)) where
getContext :: GraphRefRelationalExprM DatabaseContext
getContext = GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
UncommittedContextMarker
instance DatabaseContextM (RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity)) where
getContext :: RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getContext = RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
relVarByName :: DatabaseContextM m => RelVarName -> m GraphRefRelationalExpr
relVarByName :: AttributeName -> m GraphRefRelationalExpr
relVarByName AttributeName
rvName = do
Map AttributeName GraphRefRelationalExpr
relvars <- DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables (DatabaseContext -> Map AttributeName GraphRefRelationalExpr)
-> m DatabaseContext
-> m (Map AttributeName GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DatabaseContext
forall (m :: * -> *). DatabaseContextM m => m DatabaseContext
getContext
case AttributeName
-> Map AttributeName GraphRefRelationalExpr
-> Maybe GraphRefRelationalExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
rvName Map AttributeName GraphRefRelationalExpr
relvars of
Maybe GraphRefRelationalExpr
Nothing -> RelationalError -> m GraphRefRelationalExpr
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AttributeName -> RelationalError
RelVarNotDefinedError AttributeName
rvName)
Just GraphRefRelationalExpr
gfexpr -> GraphRefRelationalExpr -> m GraphRefRelationalExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
gfexpr
class ResolveGraphRefTransactionMarker a where
resolve :: a -> DatabaseContextEvalMonad a
instance ResolveGraphRefTransactionMarker GraphRefRelationalExpr where
resolve :: GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
resolve (MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs GraphRefTupleExprs
tupleExprs) =
Maybe [AttributeExprBase GraphRefTransactionMarker]
-> GraphRefTupleExprs -> GraphRefRelationalExpr
forall a.
Maybe [AttributeExprBase a]
-> TupleExprsBase a -> RelationalExprBase a
MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs (GraphRefTupleExprs -> GraphRefRelationalExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefTupleExprs
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTupleExprs
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefTupleExprs
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefTupleExprs
tupleExprs
resolve orig :: GraphRefRelationalExpr
orig@MakeStaticRelation{} = GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
orig
resolve orig :: GraphRefRelationalExpr
orig@ExistingRelation{} = GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
orig
resolve orig :: GraphRefRelationalExpr
orig@(RelationVariable AttributeName
rvName GraphRefTransactionMarker
UncommittedContextMarker) = do
Map AttributeName GraphRefRelationalExpr
rvMap <- DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables (DatabaseContext -> Map AttributeName GraphRefRelationalExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(Map AttributeName GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
DatabaseContext
getStateContext
case AttributeName
-> Map AttributeName GraphRefRelationalExpr
-> Maybe GraphRefRelationalExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
rvName Map AttributeName GraphRefRelationalExpr
rvMap of
Maybe GraphRefRelationalExpr
Nothing -> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
orig
Just GraphRefRelationalExpr
resolvedRv -> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
resolvedRv
resolve orig :: GraphRefRelationalExpr
orig@RelationVariable{} = GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
orig
resolve (Project AttributeNamesBase GraphRefTransactionMarker
attrNames GraphRefRelationalExpr
relExpr) = AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
AttributeNamesBase a
-> RelationalExprBase a -> RelationalExprBase a
Project (AttributeNamesBase GraphRefTransactionMarker
-> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttributeNamesBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
attrNames RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
relExpr
resolve (Union GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union (GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprA RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprB
resolve (Join GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Join (GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprA RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprB
resolve (Rename AttributeName
attrA AttributeName
attrB GraphRefRelationalExpr
expr) = AttributeName
-> AttributeName
-> GraphRefRelationalExpr
-> GraphRefRelationalExpr
forall a.
AttributeName
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
Rename AttributeName
attrA AttributeName
attrB (GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
resolve (Difference GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Difference (GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprA RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprB
resolve (Group AttributeNamesBase GraphRefTransactionMarker
namesA AttributeName
nameB GraphRefRelationalExpr
expr) = AttributeNamesBase GraphRefTransactionMarker
-> AttributeName
-> GraphRefRelationalExpr
-> GraphRefRelationalExpr
forall a.
AttributeNamesBase a
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
Group (AttributeNamesBase GraphRefTransactionMarker
-> AttributeName
-> GraphRefRelationalExpr
-> GraphRefRelationalExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeName -> GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttributeNamesBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
namesA RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeName -> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
AttributeName
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AttributeName
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
AttributeName
forall (f :: * -> *) a. Applicative f => a -> f a
pure AttributeName
nameB RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
resolve (Ungroup AttributeName
nameA GraphRefRelationalExpr
expr) = AttributeName -> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
AttributeName -> RelationalExprBase a -> RelationalExprBase a
Ungroup AttributeName
nameA (GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
resolve (Restrict RestrictionPredicateExprBase GraphRefTransactionMarker
restrictExpr GraphRefRelationalExpr
relExpr) = RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (RestrictionPredicateExprBase GraphRefTransactionMarker
-> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RestrictionPredicateExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
restrictExpr RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
relExpr
resolve (Equals GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Equals (GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprA RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprB
resolve (NotEquals GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
NotEquals (GraphRefRelationalExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprA RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprB
resolve (Extend GraphRefExtendTupleExpr
extendExpr GraphRefRelationalExpr
relExpr) = GraphRefExtendTupleExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Extend (GraphRefExtendTupleExpr
-> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefExtendTupleExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefExtendTupleExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefExtendTupleExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefExtendTupleExpr
extendExpr RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
relExpr
resolve (With WithNameAssocs
withExprs GraphRefRelationalExpr
relExpr) = WithNameAssocs -> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall a.
[(WithNameExprBase a, RelationalExprBase a)]
-> RelationalExprBase a -> RelationalExprBase a
With (WithNameAssocs
-> GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
WithNameAssocs
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((WithNameExprBase GraphRefTransactionMarker,
GraphRefRelationalExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(WithNameExprBase GraphRefTransactionMarker,
GraphRefRelationalExpr))
-> WithNameAssocs
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
WithNameAssocs
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(WithNameExprBase GraphRefTransactionMarker
nam, GraphRefRelationalExpr
expr) -> (,) (WithNameExprBase GraphRefTransactionMarker
-> GraphRefRelationalExpr
-> (WithNameExprBase GraphRefTransactionMarker,
GraphRefRelationalExpr))
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(WithNameExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr
-> (WithNameExprBase GraphRefTransactionMarker,
GraphRefRelationalExpr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithNameExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(WithNameExprBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve WithNameExprBase GraphRefTransactionMarker
nam RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr
-> (WithNameExprBase GraphRefTransactionMarker,
GraphRefRelationalExpr))
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(WithNameExprBase GraphRefTransactionMarker,
GraphRefRelationalExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr) WithNameAssocs
withExprs RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefRelationalExpr -> GraphRefRelationalExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
relExpr
instance ResolveGraphRefTransactionMarker GraphRefTupleExprs where
resolve :: GraphRefTupleExprs
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefTupleExprs
resolve (TupleExprs GraphRefTransactionMarker
marker [TupleExprBase GraphRefTransactionMarker]
tupleExprs) =
GraphRefTransactionMarker
-> [TupleExprBase GraphRefTransactionMarker] -> GraphRefTupleExprs
forall a. a -> [TupleExprBase a] -> TupleExprsBase a
TupleExprs GraphRefTransactionMarker
marker ([TupleExprBase GraphRefTransactionMarker] -> GraphRefTupleExprs)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
[TupleExprBase GraphRefTransactionMarker]
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefTupleExprs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TupleExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(TupleExprBase GraphRefTransactionMarker))
-> [TupleExprBase GraphRefTransactionMarker]
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
[TupleExprBase GraphRefTransactionMarker]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TupleExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(TupleExprBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve [TupleExprBase GraphRefTransactionMarker]
tupleExprs
instance ResolveGraphRefTransactionMarker GraphRefTupleExpr where
resolve :: TupleExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(TupleExprBase GraphRefTransactionMarker)
resolve (TupleExpr Map AttributeName GraphRefAtomExpr
tupMap) = do
[(AttributeName, GraphRefAtomExpr)]
tupMap' <- ((AttributeName, GraphRefAtomExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeName, GraphRefAtomExpr))
-> [(AttributeName, GraphRefAtomExpr)]
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
[(AttributeName, GraphRefAtomExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(AttributeName
attrName, GraphRefAtomExpr
expr) -> (,) AttributeName
attrName (GraphRefAtomExpr -> (AttributeName, GraphRefAtomExpr))
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeName, GraphRefAtomExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
expr ) (Map AttributeName GraphRefAtomExpr
-> [(AttributeName, GraphRefAtomExpr)]
forall k a. Map k a -> [(k, a)]
M.toList Map AttributeName GraphRefAtomExpr
tupMap)
TupleExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(TupleExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map AttributeName GraphRefAtomExpr
-> TupleExprBase GraphRefTransactionMarker
forall a. Map AttributeName (AtomExprBase a) -> TupleExprBase a
TupleExpr ([(AttributeName, GraphRefAtomExpr)]
-> Map AttributeName GraphRefAtomExpr
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(AttributeName, GraphRefAtomExpr)]
tupMap'))
instance ResolveGraphRefTransactionMarker GraphRefAttributeNames where
resolve :: AttributeNamesBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
resolve orig :: AttributeNamesBase GraphRefTransactionMarker
orig@AttributeNames{} = AttributeNamesBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AttributeNamesBase GraphRefTransactionMarker
orig
resolve orig :: AttributeNamesBase GraphRefTransactionMarker
orig@InvertedAttributeNames{} = AttributeNamesBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AttributeNamesBase GraphRefTransactionMarker
orig
resolve (UnionAttributeNames AttributeNamesBase GraphRefTransactionMarker
namesA AttributeNamesBase GraphRefTransactionMarker
namesB) = AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker
forall a.
AttributeNamesBase a
-> AttributeNamesBase a -> AttributeNamesBase a
UnionAttributeNames (AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttributeNamesBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
namesA RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AttributeNamesBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
namesB
resolve (IntersectAttributeNames AttributeNamesBase GraphRefTransactionMarker
namesA AttributeNamesBase GraphRefTransactionMarker
namesB) = AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker
forall a.
AttributeNamesBase a
-> AttributeNamesBase a -> AttributeNamesBase a
IntersectAttributeNames (AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttributeNamesBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
namesA RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker
-> AttributeNamesBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AttributeNamesBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
namesB
resolve (RelationalExprAttributeNames GraphRefRelationalExpr
expr) = GraphRefRelationalExpr
-> AttributeNamesBase GraphRefTransactionMarker
forall a. RelationalExprBase a -> AttributeNamesBase a
RelationalExprAttributeNames (GraphRefRelationalExpr
-> AttributeNamesBase GraphRefTransactionMarker)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(AttributeNamesBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
instance ResolveGraphRefTransactionMarker GraphRefRestrictionPredicateExpr where
resolve :: RestrictionPredicateExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
TruePredicate = RestrictionPredicateExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a. Applicative f => a -> f a
pure RestrictionPredicateExprBase GraphRefTransactionMarker
forall a. RestrictionPredicateExprBase a
TruePredicate
resolve (AndPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
exprA RestrictionPredicateExprBase GraphRefTransactionMarker
exprB) = RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker
forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
AndPredicate (RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RestrictionPredicateExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
exprA RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RestrictionPredicateExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
exprB
resolve (OrPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
exprA RestrictionPredicateExprBase GraphRefTransactionMarker
exprB) = RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker
forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
OrPredicate (RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RestrictionPredicateExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
exprA RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RestrictionPredicateExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
exprB
resolve (NotPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
expr) = RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker
forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate (RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RestrictionPredicateExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
expr
resolve (RelationalExprPredicate GraphRefRelationalExpr
expr) = GraphRefRelationalExpr
-> RestrictionPredicateExprBase GraphRefTransactionMarker
forall a. RelationalExprBase a -> RestrictionPredicateExprBase a
RelationalExprPredicate (GraphRefRelationalExpr
-> RestrictionPredicateExprBase GraphRefTransactionMarker)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
resolve (AtomExprPredicate GraphRefAtomExpr
expr) = GraphRefAtomExpr
-> RestrictionPredicateExprBase GraphRefTransactionMarker
forall a. AtomExprBase a -> RestrictionPredicateExprBase a
AtomExprPredicate (GraphRefAtomExpr
-> RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
expr
resolve (AttributeEqualityPredicate AttributeName
nam GraphRefAtomExpr
expr)= AttributeName
-> GraphRefAtomExpr
-> RestrictionPredicateExprBase GraphRefTransactionMarker
forall a.
AttributeName -> AtomExprBase a -> RestrictionPredicateExprBase a
AttributeEqualityPredicate AttributeName
nam (GraphRefAtomExpr
-> RestrictionPredicateExprBase GraphRefTransactionMarker)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(RestrictionPredicateExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
expr
instance ResolveGraphRefTransactionMarker GraphRefExtendTupleExpr where
resolve :: GraphRefExtendTupleExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefExtendTupleExpr
resolve (AttributeExtendTupleExpr AttributeName
nam GraphRefAtomExpr
atomExpr) = AttributeName -> GraphRefAtomExpr -> GraphRefExtendTupleExpr
forall a. AttributeName -> AtomExprBase a -> ExtendTupleExprBase a
AttributeExtendTupleExpr AttributeName
nam (GraphRefAtomExpr -> GraphRefExtendTupleExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefExtendTupleExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
atomExpr
instance ResolveGraphRefTransactionMarker GraphRefWithNameExpr where
resolve :: WithNameExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(WithNameExprBase GraphRefTransactionMarker)
resolve orig :: WithNameExprBase GraphRefTransactionMarker
orig@WithNameExpr{} = WithNameExprBase GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(WithNameExprBase GraphRefTransactionMarker)
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithNameExprBase GraphRefTransactionMarker
orig
instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where
resolve :: GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
resolve orig :: GraphRefAtomExpr
orig@AttributeAtomExpr{} = GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefAtomExpr
orig
resolve orig :: GraphRefAtomExpr
orig@NakedAtomExpr{} = GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefAtomExpr
orig
resolve (FunctionAtomExpr AttributeName
nam [GraphRefAtomExpr]
atomExprs GraphRefTransactionMarker
marker) =
AttributeName
-> [GraphRefAtomExpr]
-> GraphRefTransactionMarker
-> GraphRefAtomExpr
forall a. AttributeName -> [AtomExprBase a] -> a -> AtomExprBase a
FunctionAtomExpr AttributeName
nam ([GraphRefAtomExpr]
-> GraphRefTransactionMarker -> GraphRefAtomExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
[GraphRefAtomExpr]
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefTransactionMarker -> GraphRefAtomExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr)
-> [GraphRefAtomExpr]
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
[GraphRefAtomExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve [GraphRefAtomExpr]
atomExprs RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefTransactionMarker -> GraphRefAtomExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefTransactionMarker
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefTransactionMarker
marker
resolve (RelationAtomExpr GraphRefRelationalExpr
expr) = GraphRefRelationalExpr -> GraphRefAtomExpr
forall a. RelationalExprBase a -> AtomExprBase a
RelationAtomExpr (GraphRefRelationalExpr -> GraphRefAtomExpr)
-> DatabaseContextEvalMonad GraphRefRelationalExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExpr
-> DatabaseContextEvalMonad GraphRefRelationalExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
resolve (ConstructedAtomExpr AttributeName
dConsName [GraphRefAtomExpr]
atomExprs GraphRefTransactionMarker
marker) =
AttributeName
-> [GraphRefAtomExpr]
-> GraphRefTransactionMarker
-> GraphRefAtomExpr
forall a. AttributeName -> [AtomExprBase a] -> a -> AtomExprBase a
ConstructedAtomExpr AttributeName
dConsName ([GraphRefAtomExpr]
-> GraphRefTransactionMarker -> GraphRefAtomExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
[GraphRefAtomExpr]
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefTransactionMarker -> GraphRefAtomExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr)
-> [GraphRefAtomExpr]
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
[GraphRefAtomExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GraphRefAtomExpr
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve [GraphRefAtomExpr]
atomExprs RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
(GraphRefTransactionMarker -> GraphRefAtomExpr)
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefAtomExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphRefTransactionMarker
-> RWST
DatabaseContextEvalEnv
()
DatabaseContextEvalState
(ExceptT RelationalError Identity)
GraphRefTransactionMarker
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefTransactionMarker
marker
applyUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr
applyUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr
applyUnionCollapse = (Base GraphRefRelationalExpr GraphRefRelationalExpr
-> GraphRefRelationalExpr)
-> GraphRefRelationalExpr -> GraphRefRelationalExpr
forall t a. Recursive t => (Base t a -> a) -> t -> a
Fold.cata Base GraphRefRelationalExpr GraphRefRelationalExpr
-> GraphRefRelationalExpr
RelationalExprBaseF
GraphRefTransactionMarker GraphRefRelationalExpr
-> GraphRefRelationalExpr
opt
where
opt :: RelationalExprBaseF GraphRefTransactionMarker GraphRefRelationalExpr -> GraphRefRelationalExpr
opt :: RelationalExprBaseF
GraphRefTransactionMarker GraphRefRelationalExpr
-> GraphRefRelationalExpr
opt (UnionF GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) | GraphRefRelationalExpr
exprA GraphRefRelationalExpr -> GraphRefRelationalExpr -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== GraphRefRelationalExpr
exprB = GraphRefRelationalExpr
exprA
opt (UnionF
exprA :: GraphRefRelationalExpr
exprA@(MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs1 GraphRefTupleExprs
tupExprs1)
exprB :: GraphRefRelationalExpr
exprB@(MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs2 GraphRefTupleExprs
tupExprs2)) | GraphRefTupleExprs
tupExprs1 GraphRefTupleExprs -> GraphRefTupleExprs -> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== GraphRefTupleExprs
tupExprs2 = Maybe [AttributeExprBase GraphRefTransactionMarker]
-> GraphRefTupleExprs -> GraphRefRelationalExpr
forall a.
Maybe [AttributeExprBase a]
-> TupleExprsBase a -> RelationalExprBase a
MakeRelationFromExprs (Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs1 Maybe [AttributeExprBase GraphRefTransactionMarker]
-> Maybe [AttributeExprBase GraphRefTransactionMarker]
-> Maybe [AttributeExprBase GraphRefTransactionMarker]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs2) GraphRefTupleExprs
tupExprs1
| GraphRefTupleExprs -> DirtyFlag
forall a. TupleExprsBase a -> DirtyFlag
tupExprsNull GraphRefTupleExprs
tupExprs1 = GraphRefRelationalExpr
exprB
| GraphRefTupleExprs -> DirtyFlag
forall a. TupleExprsBase a -> DirtyFlag
tupExprsNull GraphRefTupleExprs
tupExprs2 = GraphRefRelationalExpr
exprA
opt RelationalExprBaseF
GraphRefTransactionMarker GraphRefRelationalExpr
x = Base GraphRefRelationalExpr GraphRefRelationalExpr
-> GraphRefRelationalExpr
forall t. Corecursive t => Base t t -> t
Fold.embed Base GraphRefRelationalExpr GraphRefRelationalExpr
RelationalExprBaseF
GraphRefTransactionMarker GraphRefRelationalExpr
x
tupExprsNull :: TupleExprsBase a -> DirtyFlag
tupExprsNull (TupleExprs a
_ []) = DirtyFlag
True
tupExprsNull TupleExprsBase a
_ = DirtyFlag
False
applyRestrictionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr
applyRestrictionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr
applyRestrictionCollapse orig :: GraphRefRelationalExpr
orig@(Restrict npred :: RestrictionPredicateExprBase GraphRefTransactionMarker
npred@(NotPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
_) GraphRefRelationalExpr
expr) =
case GraphRefRelationalExpr
expr of
orig' :: GraphRefRelationalExpr
orig'@(Restrict npred' :: RestrictionPredicateExprBase GraphRefTransactionMarker
npred'@(NotPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
_) GraphRefRelationalExpr
_) | RestrictionPredicateExprBase GraphRefTransactionMarker
npred RestrictionPredicateExprBase GraphRefTransactionMarker
-> RestrictionPredicateExprBase GraphRefTransactionMarker
-> DirtyFlag
forall a. Eq a => a -> a -> DirtyFlag
== RestrictionPredicateExprBase GraphRefTransactionMarker
npred' -> GraphRefRelationalExpr
orig'
GraphRefRelationalExpr
_ -> GraphRefRelationalExpr
orig
applyRestrictionCollapse GraphRefRelationalExpr
expr = GraphRefRelationalExpr
expr