{-# 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 = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"impossible counting error in singletonTuple") (Relation -> Maybe RelationTuple
singletonTuple Relation
relIn)
existingCount :: Int
existingCount = case forall a. Vector a -> a
V.head (RelationTuple -> Vector Atom
tupleAtoms RelationTuple
existingTuple) of
IntAtom Int
v -> Int
v
Atom
_ -> 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 forall a. Num a => a -> a -> a
+ Int
1)]] of
Left RelationalError
err -> forall a. HasCallStack => [Char] -> a
error ([Char]
"impossible counting error in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RelationalError
err)
Right RelationTupleSet
ts -> RelationTupleSet
ts
mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState
mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState
mkDatabaseContextEvalState DatabaseContext
context = DatabaseContextEvalState {
dbc_context :: DatabaseContext
dbc_context = DatabaseContext
context,
dbc_accum :: Map AttributeName ResultAccum
dbc_accum = 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 = forall a b. a -> Either a b -> a
fromLeft RelationTuple
emptyTuple (forall a. a -> Maybe a -> a
fromMaybe (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 = forall b a. b -> Either a b -> b
fromRight Attributes
emptyAttributes (forall a. a -> Maybe a -> a
fromMaybe (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 " forall a. [a] -> [a] -> [a]
++ 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 :: forall a.
RelationalExprEnv -> RelationalExprM a -> Either RelationalError a
runRelationalExprM RelationalExprEnv
env RelationalExprM a
m = forall a. Identity a -> a
runIdentity (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RelationalExprM a
m RelationalExprEnv
env))
reGraph :: RelationalExprM TransactionGraph
reGraph :: RelationalExprM TransactionGraph
reGraph = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RelationalExprEnv -> TransactionGraph
re_graph
reContext :: RelationalExprM DatabaseContext
reContext :: RelationalExprM DatabaseContext
reContext = 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
{ re_context :: DatabaseContext
re_context = DatabaseContext
ctx,
re_graph :: TransactionGraph
re_graph = TransactionGraph
graph,
re_extra :: Maybe (Either RelationTuple Attributes)
re_extra = forall a. Maybe a
Nothing }
askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv = 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 = forall {b}. Maybe (Either RelationTuple b)
new_elems }
where
new_elems :: Maybe (Either RelationTuple b)
new_elems = forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left RelationTuple
newTuple)
mergedTupMap :: Map AttributeName Atom
mergedTupMap = 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 = forall {a}. Maybe (Either a Attributes)
newattrs }
where
newattrs :: Maybe (Either a Attributes)
newattrs = forall a. a -> Maybe a
Just (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 = forall a. Identity a -> a
runIdentity (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
RWS.ask
dbcGraph :: DatabaseContextEvalMonad TransactionGraph
dbcGraph :: DatabaseContextEvalMonad TransactionGraph
dbcGraph = DatabaseContextEvalEnv -> TransactionGraph
dce_graph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
RWS.ask
dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv
dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv
dbcRelationalExprEnv =
DatabaseContext -> TransactionGraph -> RelationalExprEnv
mkRelationalExprEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatabaseContextEvalMonad DatabaseContext
getStateContext forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DatabaseContextEvalMonad TransactionGraph
dbcGraph
getStateContext :: DatabaseContextEvalMonad DatabaseContext
getStateContext :: DatabaseContextEvalMonad DatabaseContext
getStateContext = 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 <- forall s (m :: * -> *). MonadState s m => m s
get
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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefRelationalExprM GraphRefRelationalExprEnv
askEnv
case Maybe DatabaseContext
mctx of
Maybe DatabaseContext
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
NoUncommittedContextInEvalError
Just DatabaseContext
ctx -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseContext
ctx
runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM :: forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
env GraphRefRelationalExprM a
m = forall a. Identity a -> a
runIdentity (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (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 {
gre_context :: Maybe DatabaseContext
gre_context = Maybe DatabaseContext
mctx,
gre_graph :: TransactionGraph
gre_graph = TransactionGraph
graph,
gre_extra :: Maybe (Either RelationTuple Attributes)
gre_extra = forall a. Maybe a
Nothing
}
gfGraph :: GraphRefRelationalExprM TransactionGraph
gfGraph :: GraphRefRelationalExprM TransactionGraph
gfGraph = 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 <- DatabaseContextEvalMonad DatabaseContext
getStateContext
GraphRefRelationalExpr
relExpr' <- forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
relExpr
let newRelVars :: Map AttributeName GraphRefRelationalExpr
newRelVars = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AttributeName
relVarName GraphRefRelationalExpr
relExpr' 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 forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
relVarName (DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables DatabaseContext
currentContext) forall a. Eq a => a -> a -> DirtyFlag
== forall a. a -> Maybe a
Just GraphRefRelationalExpr
relExpr then
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 <- DatabaseContextEvalMonad DatabaseContext
getStateContext
let relVars :: Map AttributeName GraphRefRelationalExpr
relVars = DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables DatabaseContext
currContext
if forall k a. Ord k => k -> Map k a -> DirtyFlag
M.notMember AttributeName
relVarName Map AttributeName GraphRefRelationalExpr
relVars then
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else do
let newRelVars :: Map AttributeName GraphRefRelationalExpr
newRelVars = 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
evalGraphRefDatabaseContextExpr (Define AttributeName
relVarName [AttributeExprBase GraphRefTransactionMarker]
attrExprs) = do
DatabaseContext
context <- DatabaseContextEvalMonad DatabaseContext
getStateContext
Map AttributeName GraphRefRelationalExpr
relvars <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables DatabaseContextEvalMonad DatabaseContext
getStateContext
TypeConstructorMapping
tConss <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContextEvalMonad DatabaseContext
getStateContext
TransactionGraph
graph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
let eAttrs :: Either RelationalError [Attribute]
eAttrs = forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AttributeExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM Attribute
evalGraphRefAttrExpr [AttributeExprBase GraphRefTransactionMarker]
attrExprs)
gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ TypeConstructorMapping -> Attributes -> Either RelationalError ()
validateAttributes TypeConstructorMapping
tConss ([Attribute] -> Attributes
A.attributesFromList [Attribute]
attrsList)
case 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 (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatabaseContextEvalMonad RelationalExprEnv
dbcRelationalExprEnv
DatabaseContext
context <- DatabaseContextEvalMonad DatabaseContext
getStateContext
let existingRelVar :: Maybe GraphRefRelationalExpr
existingRelVar = 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 (forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
eNewExprType :: Either RelationalError Relation
eNewExprType = 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 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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 = 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 forall a. Eq a => a -> a -> DirtyFlag
== Relation
expectedType then do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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 <- forall (m :: * -> *).
DatabaseContextM m =>
AttributeName -> m GraphRefRelationalExpr
relVarByName AttributeName
relVarName
let optExpr :: GraphRefRelationalExpr
optExpr = GraphRefRelationalExpr -> GraphRefRelationalExpr
applyUnionCollapse (forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union
GraphRefRelationalExpr
relExpr
GraphRefRelationalExpr
gfExpr)
GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
evalGraphRefDatabaseContextExpr (forall a.
AttributeName -> RelationalExprBase a -> DatabaseContextExprBase a
Assign AttributeName
relVarName GraphRefRelationalExpr
optExpr)
evalGraphRefDatabaseContextExpr (Delete AttributeName
relVarName RestrictionPredicateExprBase GraphRefTransactionMarker
predicate) = do
GraphRefRelationalExpr
gfExpr <- forall (m :: * -> *).
DatabaseContextM m =>
AttributeName -> m GraphRefRelationalExpr
relVarByName AttributeName
relVarName
let optExpr :: GraphRefRelationalExpr
optExpr = GraphRefRelationalExpr -> GraphRefRelationalExpr
applyRestrictionCollapse (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (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 <- forall (m :: * -> *).
DatabaseContextM m =>
AttributeName -> m GraphRefRelationalExpr
relVarByName AttributeName
relVarName
TransactionGraph
graph <- RelationalExprEnv -> TransactionGraph
re_graph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatabaseContextEvalMonad RelationalExprEnv
dbcRelationalExprEnv
DatabaseContext
context <- DatabaseContextEvalMonad DatabaseContext
getStateContext
let reEnv :: GraphRefRelationalExprEnv
reEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
eExprType :: Either RelationalError Relation
eExprType = 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 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right Relation
t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
t
let unrestrictedPortion :: GraphRefRelationalExpr
unrestrictedPortion = forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (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_" forall a. Semigroup a => a -> a -> a
<> [Char] -> AttributeName
T.pack (forall a. Show a => a -> [Char]
show Int
c) forall a. Semigroup a => a -> a -> a
<> AttributeName
attr in
if AttributeName
tmpAttrName 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
cforall 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 = forall a.
ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Extend (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 = forall a.
AttributeName
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
Rename (AttributeName -> AttributeName
tmpAttr AttributeName
attr) AttributeName
attr (forall a.
AttributeNamesBase a
-> RelationalExprBase a -> RelationalExprBase a
Project (forall a. Set AttributeName -> AttributeNamesBase a
InvertedAttributeNames (forall a. a -> Set a
S.singleton AttributeName
attr)) RelationalExprBase a
expr)
restrictedPortion :: GraphRefRelationalExpr
restrictedPortion = forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict RestrictionPredicateExprBase GraphRefTransactionMarker
pred' GraphRefRelationalExpr
rvExpr
updated :: GraphRefRelationalExpr
updated = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(AttributeName
oldname, AtomExpr
atomExpr) GraphRefRelationalExpr
accum ->
let procAtomExpr :: GraphRefAtomExpr
procAtomExpr = forall a. GraphRefTransactionMarker -> ProcessExprM a -> a
runProcessExprM GraphRefTransactionMarker
UncommittedContextMarker (AtomExpr -> ProcessExprM GraphRefAtomExpr
processAtomExpr AtomExpr
atomExpr) in
forall {a}.
AttributeName
-> AtomExprBase a -> RelationalExprBase a -> RelationalExprBase a
updateAttr AttributeName
oldname GraphRefAtomExpr
procAtomExpr GraphRefRelationalExpr
accum
) GraphRefRelationalExpr
restrictedPortion (forall k a. Map k a -> [(k, a)]
M.toList AttributeNameAtomExprMap
atomExprMap)
updatedPortion :: GraphRefRelationalExpr
updatedPortion = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}.
AttributeName -> RelationalExprBase a -> RelationalExprBase a
projectAndRename GraphRefRelationalExpr
updated (forall k a. Map k a -> [k]
M.keys AttributeNameAtomExprMap
atomExprMap)
AttributeName
-> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar AttributeName
relVarName (forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union GraphRefRelationalExpr
unrestrictedPortion GraphRefRelationalExpr
updatedPortion)
evalGraphRefDatabaseContextExpr (AddInclusionDependency AttributeName
newDepName InclusionDependency
newDep) = do
DatabaseContext
currContext <- DatabaseContextEvalMonad DatabaseContext
getStateContext
TransactionId
transId <- DatabaseContextEvalMonad TransactionId
dbcTransId
TransactionGraph
graph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
let currDeps :: InclusionDependencies
currDeps = DatabaseContext -> InclusionDependencies
inclusionDependencies DatabaseContext
currContext
newDeps :: InclusionDependencies
newDeps = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AttributeName
newDepName InclusionDependency
newDep InclusionDependencies
currDeps
if 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 <- DatabaseContextEvalMonad DatabaseContext
getStateContext
let currDeps :: InclusionDependencies
currDeps = DatabaseContext -> InclusionDependencies
inclusionDependencies DatabaseContext
currContext
newDeps :: InclusionDependencies
newDeps = forall k a. Ord k => k -> Map k a -> Map k a
M.delete AttributeName
depName InclusionDependencies
currDeps
if 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 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 <- DatabaseContextEvalMonad DatabaseContext
getStateContext
let nots :: Notifications
nots = DatabaseContext -> Notifications
notifications DatabaseContext
currentContext
if 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 = 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 { changeExpr :: RelationalExpr
changeExpr = RelationalExpr
triggerExpr,
reportOldExpr :: RelationalExpr
reportOldExpr = RelationalExpr
resultOldExpr,
reportNewExpr :: RelationalExpr
reportNewExpr = RelationalExpr
resultNewExpr}
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext forall a b. (a -> b) -> a -> b
$ DatabaseContext
currentContext { notifications :: Notifications
notifications = Notifications
newNotifications }
evalGraphRefDatabaseContextExpr (RemoveNotification AttributeName
notName) = do
DatabaseContext
currentContext <- DatabaseContextEvalMonad DatabaseContext
getStateContext
let nots :: Notifications
nots = DatabaseContext -> Notifications
notifications DatabaseContext
currentContext
if 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 = forall k a. Ord k => k -> Map k a -> Map k a
M.delete AttributeName
notName Notifications
nots
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext forall a b. (a -> b) -> a -> b
$ DatabaseContext
currentContext { notifications :: Notifications
notifications = Notifications
newNotifications }
evalGraphRefDatabaseContextExpr (AddTypeConstructor TypeConstructorDef
tConsDef [DataConstructorDef]
dConsDefList) = do
DatabaseContext
currentContext <- DatabaseContextEvalMonad 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 -> 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)
| 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 forall a. [a] -> [a] -> [a]
++ [(TypeConstructorDef
tConsDef, [DataConstructorDef]
dConsDefList)]
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext forall a b. (a -> b) -> a -> b
$ DatabaseContext
currentContext { typeConstructorMapping :: TypeConstructorMapping
typeConstructorMapping = TypeConstructorMapping
newTypes }
evalGraphRefDatabaseContextExpr (RemoveTypeConstructor AttributeName
tConsName) = do
DatabaseContext
currentContext <- DatabaseContextEvalMonad DatabaseContext
getStateContext
let oldTypes :: TypeConstructorMapping
oldTypes = DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
currentContext
if 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 = forall a. (a -> DirtyFlag) -> [a] -> [a]
filter (\(TypeConstructorDef
tCons, [DataConstructorDef]
_) -> TypeConstructorDef -> AttributeName
TCD.name TypeConstructorDef
tCons forall a. Eq a => a -> a -> DirtyFlag
/= AttributeName
tConsName) TypeConstructorMapping
oldTypes
DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext forall a b. (a -> b) -> a -> b
$ DatabaseContext
currentContext { typeConstructorMapping :: TypeConstructorMapping
typeConstructorMapping = TypeConstructorMapping
newTypes }
evalGraphRefDatabaseContextExpr (MultipleExpr [GraphRefDatabaseContextExpr]
exprs) =
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 <- DatabaseContextEvalMonad 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 = 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 <- DatabaseContextEvalMonad 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 = 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 <- DatabaseContextEvalMonad DatabaseContext
getStateContext
TransactionGraph
graph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
let eAtomTypes :: Either RelationalError [AtomType]
eAtomTypes = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv 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 (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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Function a -> [AtomType]
funcType DatabaseContextFunction
func)
actualArgCount :: Int
actualArgCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length [GraphRefAtomExpr]
atomArgExprs
if Int
expectedArgCount 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 = 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 -> forall a. a -> Maybe a
Just RelationalError
err
Right AtomType
_ -> forall a. Maybe a
Nothing)
(forall a. Function a -> [AtomType]
funcType DatabaseContextFunction
func) [AtomType]
atomTypes
typeErrors :: [RelationalError]
typeErrors = forall a. [Maybe a] -> [a]
catMaybes [Maybe RelationalError]
mValidTypes
eAtomArgs :: [Either RelationalError Atom]
eAtomArgs = forall a b. (a -> b) -> [a] -> [b]
map (forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
emptyTuple) [GraphRefAtomExpr]
atomArgExprs
if forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a b. [Either a b] -> [a]
lefts [Either RelationalError Atom]
eAtomArgs) forall a. Ord a => a -> a -> DirtyFlag
> Int
1 then
RelationalError -> DatabaseContextEvalMonad ()
dbErr ([RelationalError] -> RelationalError
someErrors (forall a b. [Either a b] -> [a]
lefts [Either RelationalError Atom]
eAtomArgs))
else if DirtyFlag -> DirtyFlag
not (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 (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 <- DatabaseContextEvalMonad DatabaseContext
getStateContext
TransactionGraph
tgraph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
TransactionId
tid <- DatabaseContextEvalMonad TransactionId
dbcTransId
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
regName (DatabaseContext -> RegisteredQueries
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 :: RegisteredQueries
registeredQueries = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AttributeName
regName RelationalExpr
regExpr (DatabaseContext -> RegisteredQueries
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 <- DatabaseContextEvalMonad DatabaseContext
getStateContext
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
regName (DatabaseContext -> RegisteredQueries
registeredQueries DatabaseContext
context) of
Maybe RelationalExpr
Nothing -> RelationalError -> DatabaseContextEvalMonad ()
dbErr (AttributeName -> RelationalError
RegisteredQueryNameNotInUseError AttributeName
regName)
Just RelationalExpr
_ -> DatabaseContext -> DatabaseContextEvalMonad ()
putStateContext (DatabaseContext
context { registeredQueries :: RegisteredQueries
registeredQueries = forall k a. Ord k => k -> Map k a -> Map k a
M.delete AttributeName
regName (DatabaseContext -> RegisteredQueries
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 <- 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
_,()
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RelationalError
err)
(Right (),DatabaseContextEvalState
s,()
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 <- forall r (m :: * -> *). MonadReader r m => m r
RWS.ask
case DatabaseContextIOEvalEnv -> Maybe ScriptSession
dbcio_mScriptSession DatabaseContextIOEvalEnv
env of
Maybe ScriptSession
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ScriptCompilationError -> RelationalError
ScriptError ScriptCompilationError
ScriptCompilationDisabledError
Just ScriptSession
ss -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ScriptSession
ss)
putDBCIOContext :: DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext :: DatabaseContext
-> DatabaseContextIOEvalMonad (Either RelationalError ())
putDBCIOContext DatabaseContext
ctx = do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
RWS.modify (\DatabaseContextEvalState
dbstate -> DatabaseContextEvalState
dbstate { dbc_context :: DatabaseContext
dbc_context = DatabaseContext
ctx})
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ())
getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext = DatabaseContextEvalState -> DatabaseContext
dbc_context forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatabaseContextIOEvalEnv -> TransactionGraph
dbcio_graph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RelationalError
err)
Right ScriptSession
scriptSession -> do
Either SomeException (Either RelationalError DatabaseContext)
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a. Maybe [Char] -> Ghc a -> IO a
runGhc (forall a. a -> Maybe a
Just [Char]
libdir) forall a b. (a -> b) -> a -> b
$ do
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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RelationalError
err)
Right [TypeConstructor]
adjustedAtomTypeCons -> do
Either ScriptCompilationError AtomFunctionBodyType
eCompiledFunc <- forall a.
Type -> AttributeName -> Ghc (Either ScriptCompilationError a)
compileScript (ScriptSession -> Type
atomFunctionBodyType ScriptSession
scriptSession) AttributeName
script
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either ScriptCompilationError AtomFunctionBodyType
eCompiledFunc of
Left ScriptCompilationError
err -> forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError ScriptCompilationError
err)
Right AtomFunctionBodyType
compiledFunc -> do
[AtomType]
funcAtomType <- 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) forall k a. Map k a
M.empty) [TypeConstructor]
adjustedAtomTypeCons
let updatedFuncs :: AtomFunctions
updatedFuncs = 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 { funcName :: AttributeName
funcName = AttributeName
funcName',
funcType :: [AtomType]
funcType = [AtomType]
funcAtomType,
funcBody :: FunctionBody AtomFunctionBodyType
funcBody = forall a. AttributeName -> a -> FunctionBody a
FunctionScriptBody AttributeName
script AtomFunctionBodyType
compiledFunc }
if forall a. (Eq a, Hashable a) => a -> HashSet a -> DirtyFlag
HS.member AttributeName
funcName' (forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
HS.map forall a. Function a -> AttributeName
funcName AtomFunctions
atomFuncs) then
forall a b. a -> Either a b
Left (AttributeName -> RelationalError
FunctionNameInUseError AttributeName
funcName')
else
forall a b. b -> Either a b
Right DatabaseContext
newContext
case Either SomeException (Either RelationalError DatabaseContext)
res of
Left (SomeException
exc :: SomeException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError ([Char] -> ScriptCompilationError
OtherScriptCompilationError (forall a. Show a => a -> [Char]
show SomeException
exc)))
Right Either RelationalError DatabaseContext
eContext -> case Either RelationalError DatabaseContext
eContext of
Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RelationalError
err)
Right ScriptSession
scriptSession -> do
let last2Args :: [TypeConstructor]
last2Args = forall a. [a] -> [a]
reverse (forall a. Int -> [a] -> [a]
take Int
2 (forall a. [a] -> [a]
reverse [TypeConstructor]
funcType'))
atomArgs :: [TypeConstructor]
atomArgs = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeConstructor]
funcType' forall a. Num a => a -> a -> a
- Int
2) [TypeConstructor]
funcType'
dbContextTypeCons :: TypeConstructorBase a
dbContextTypeCons = forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"Either" [forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"DatabaseContextFunctionError" [], forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"DatabaseContext" []]
expectedType :: [Char]
expectedType = [Char]
"DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"
actualType :: [Char]
actualType = forall a. Show a => a -> [Char]
show [TypeConstructor]
funcType'
if [TypeConstructor]
last2Args forall a. Eq a => a -> a -> DirtyFlag
/= [forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"DatabaseContext" [], forall {a}. TypeConstructorBase a
dbContextTypeCons] then
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a. Maybe [Char] -> Ghc a -> IO a
runGhc (forall a. a -> Maybe a
Just [Char]
libdir) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (ScriptSession -> HscEnv
hscEnv ScriptSession
scriptSession)
Either ScriptCompilationError DatabaseContextFunctionBodyType
eCompiledFunc <- forall a.
Type -> AttributeName -> Ghc (Either ScriptCompilationError a)
compileScript (ScriptSession -> Type
dbcFunctionBodyType ScriptSession
scriptSession) AttributeName
script
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either ScriptCompilationError DatabaseContextFunctionBodyType
eCompiledFunc of
Left ScriptCompilationError
err -> forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError ScriptCompilationError
err)
Right DatabaseContextFunctionBodyType
compiledFunc -> do
[AtomType]
funcAtomType <- 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) forall k a. Map k a
M.empty) [TypeConstructor]
atomArgs
let updatedDBCFuncs :: DatabaseContextFunctions
updatedDBCFuncs = 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 {
funcName :: AttributeName
funcName = AttributeName
funcName',
funcType :: [AtomType]
funcType = [AtomType]
funcAtomType,
funcBody :: FunctionBody DatabaseContextFunctionBodyType
funcBody = forall a. AttributeName -> a -> FunctionBody a
FunctionScriptBody AttributeName
script DatabaseContextFunctionBodyType
compiledFunc
}
if forall a. (Eq a, Hashable a) => a -> HashSet a -> DirtyFlag
HS.member AttributeName
funcName' (forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
HS.map forall a. Function a -> AttributeName
funcName DatabaseContextFunctions
dbcFuncs) then
forall a b. a -> Either a b
Left (AttributeName -> RelationalError
FunctionNameInUseError AttributeName
funcName')
else
forall a b. b -> Either a b
Right DatabaseContext
newContext
case Either SomeException (Either RelationalError DatabaseContext)
res of
Left (SomeException
exc :: SomeException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError ([Char] -> ScriptCompilationError
OtherScriptCompilationError (forall a. Show a => a -> [Char]
show SomeException
exc)))
Right Either RelationalError DatabaseContext
eContext -> case Either RelationalError DatabaseContext
eContext of
Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RelationalError
LoadFunctionError)
Left LoadSymbolError
SecurityLoadSymbolError -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 = 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 = forall a. Eq a => HashSet a -> HashSet a -> HashSet a
HS.union (DatabaseContext -> AtomFunctions
atomFunctions DatabaseContext
currentContext) (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
Either LoadSymbolError [DatabaseContextFunction]
eLoadFunc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RelationalError
LoadFunctionError)
Left LoadSymbolError
SecurityLoadSymbolError -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 = forall a. Eq a => HashSet a -> HashSet a -> HashSet a
HS.union (DatabaseContext -> DatabaseContextFunctions
dbcFunctions DatabaseContext
currentContext) (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [DatabaseContextFunction]
processedDBCFuncs)
processedDBCFuncs :: [DatabaseContextFunction]
processedDBCFuncs = 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 <- forall r (m :: * -> *). MonadReader r m => m r
RWS.ask
let gfExpr :: GraphRefDatabaseContextExpr
gfExpr = 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left RelationalError
err)
Right DatabaseContextEvalState
dbstate -> do
let existingRelVar :: Maybe GraphRefRelationalExpr
existingRelVar = 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 (forall a. a -> Maybe a
Just DatabaseContext
currentContext) TransactionGraph
graph
case forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
existingRel) of
Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Gen a -> IO a
generate forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Attributes
-> Range -> WithTCMap Gen (Either RelationalError Relation)
arbitraryRelation Attributes
expectedAttributes Range
range) TypeConstructorMapping
tcMap
case Either RelationalError Relation
eitherRel of
Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 (forall a. Relation -> RelationalExprBase a
ExistingRelation Relation
rel)) of
Left RelationalError
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry AttributeName -> InclusionDependency -> Either RelationalError ()
checkIncDep) (forall k a. Map k a -> [(k, a)]
M.toList InclusionDependencies
deps)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AttributeName, RelationalExpr) -> Either RelationalError ()
checkRegisteredQuery (forall k a. Map k a -> [(k, a)]
M.toList (DatabaseContext -> RegisteredQueries
registeredQueries DatabaseContext
context))
where
potentialGraph :: TransactionGraph
potentialGraph = TransactionHeads -> Set Transaction -> TransactionGraph
TransactionGraph TransactionHeads
graphHeads (forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
tempTrans Set Transaction
transSet)
tempStamp :: UTCTime
tempStamp = UTCTime { utctDay :: Day
utctDay = Year -> Int -> Int -> Day
fromGregorian Year
2000 Int
1 Int
1,
utctDayTime :: DiffTime
utctDayTime = Year -> DiffTime
secondsToDiffTime Year
0 }
tempSchemas :: Schemas
tempSchemas = DatabaseContext -> Subschemas -> Schemas
Schemas DatabaseContext
context 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 { parents :: TransactionParents
parents = TransactionId
transId forall a. a -> [a] -> NonEmpty a
NE.:| [],
stamp :: UTCTime
stamp = UTCTime
tempStamp,
merkleHash :: MerkleHash
merkleHash = forall a. Monoid a => a
mempty
}
deps :: InclusionDependencies
deps = DatabaseContext -> InclusionDependencies
inclusionDependencies DatabaseContext
context
process :: ProcessExprM a -> a
process = forall a. GraphRefTransactionMarker -> ProcessExprM a -> a
runProcessExprM GraphRefTransactionMarker
UncommittedContextMarker
gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (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 = forall {a}. ProcessExprM a -> a
process (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
subsetExpr)
gfSupersetExpr :: GraphRefRelationalExpr
gfSupersetExpr = forall {a}. ProcessExprM a -> a
process (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
supersetExpr)
runGfRel :: GraphRefRelationalExprM b -> Either RelationalError b
runGfRel GraphRefRelationalExprM b
e = case forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv GraphRefRelationalExprM b
e of
Left RelationalError
err -> forall a b. a -> Either a b
Left (Maybe RelationalError -> RelationalError
wrapIncDepErr (forall a. a -> Maybe a
Just RelationalError
err))
Right b
v -> forall a b. b -> Either a b
Right b
v
wrapIncDepErr :: Maybe RelationalError -> RelationalError
wrapIncDepErr = AttributeName -> Maybe RelationalError -> RelationalError
InclusionDependencyCheckError AttributeName
depName
Relation
typeSub <- forall {b}. GraphRefRelationalExprM b -> Either RelationalError b
runGfRel (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfSubsetExpr)
Relation
typeSuper <- forall {b}. GraphRefRelationalExprM b -> Either RelationalError b
runGfRel (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfSupersetExpr)
forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
when (Relation
typeSub forall a. Eq a => a -> a -> DirtyFlag
/= Relation
typeSuper) (forall a b. a -> Either a b
Left (Maybe RelationalError -> RelationalError
wrapIncDepErr (forall a. a -> Maybe a
Just (Attributes -> Attributes -> RelationalError
RelationTypeMismatchError (Relation -> Attributes
attributes Relation
typeSub) (Relation -> Attributes
attributes Relation
typeSuper)))))
let checkExpr :: GraphRefRelationalExpr
checkExpr = forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Equals GraphRefRelationalExpr
gfSupersetExpr (forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union GraphRefRelationalExpr
gfSubsetExpr GraphRefRelationalExpr
gfSupersetExpr)
gfEvald :: Either RelationalError Relation
gfEvald = 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 (forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
potentialGraph
case Either RelationalError Relation
gfEvald of
Left RelationalError
err -> forall a b. a -> Either a b
Left (Maybe RelationalError -> RelationalError
wrapIncDepErr (forall a. a -> Maybe a
Just RelationalError
err))
Right Relation
resultRel -> if Relation
resultRel forall a. Eq a => a -> a -> DirtyFlag
== Relation
relationTrue then
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else
forall a b. a -> Either a b
Left (Maybe RelationalError -> RelationalError
wrapIncDepErr forall a. Maybe a
Nothing)
checkRegisteredQuery :: (AttributeName, RelationalExpr) -> Either RelationalError ()
checkRegisteredQuery (AttributeName
qName, RelationalExpr
relExpr) = do
let gfExpr :: GraphRefRelationalExpr
gfExpr = forall {a}. ProcessExprM a -> a
process (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
relExpr)
case forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfExpr) of
Left RelationalError
err -> forall a b. a -> Either a b
Left (AttributeName -> RelationalError -> RelationalError
RegisteredQueryValidationError AttributeName
qName RelationalError
err)
Right Relation
_ -> 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 = forall a. GraphRefTransactionMarker -> ProcessExprM a -> a
runProcessExprM GraphRefTransactionMarker
UncommittedContextMarker (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
expr)
gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
runGf :: Either RelationalError Relation
runGf = forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfExpr)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) a b.
Monad m =>
m (Either a b) -> ExceptT a m b
liftE m (Either a b)
v = do
Either a b
y <- 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 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a
err
Right b
val -> 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\RelationTuple
x -> do
DirtyFlag
ev1 <- RestrictionFilter
expr1v RelationTuple
x
DirtyFlag
ev2 <- RestrictionFilter
expr2v RelationTuple
x
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\RelationTuple
x -> do
DirtyFlag
ev1 <- RestrictionFilter
expr1v RelationTuple
x
DirtyFlag
ev2 <- RestrictionFilter
expr2v RelationTuple
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DirtyFlag
ev1 DirtyFlag -> DirtyFlag -> DirtyFlag
|| DirtyFlag
ev2))
predicateRestrictionFilter Attributes
_ RestrictionPredicateExprBase GraphRefTransactionMarker
TruePredicate = forall (f :: * -> *) a. Applicative f => a -> f a
pure (\RelationTuple
_ -> 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DirtyFlag -> DirtyFlag
not 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
forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
relExpr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\RelationTuple
tup -> case RelationTuple -> Either RelationalError Relation
eval RelationTuple
tup of
Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
Right Relation
rel -> if Relation -> Int
arity Relation
rel forall a. Eq a => a -> a -> DirtyFlag
/= Int
0 then
forall a b. a -> Either a b
Left (AttributeName -> RelationalError
PredicateExpressionError AttributeName
"Relational restriction filter must evaluate to 'true' or 'false'")
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Relation
rel 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ case AttributeName -> Attributes -> Either RelationalError Attribute
A.attributeForName AttributeName
attrName Attributes
attrs' of
Right Attribute
attr -> 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 -> forall a b. b -> Either a b
Right Attribute
ctxattr
Left err2 :: RelationalError
err2@(NoSuchAttributeNamesError Set AttributeName
_) -> forall a b. a -> Either a b
Left RelationalError
err2
Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
if AtomType
atomExprType forall a. Eq a => a -> a -> DirtyFlag
/= Attribute -> AtomType
A.atomType Attribute
attr then
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Attributes -> RelationalError
TupleAttributeTypeMismatchError ([Attribute] -> Attributes
A.attributesFromList [Attribute
attr]))
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall a. Eq a => a -> a -> DirtyFlag
== Atom
atomIn
Left RelationalError
_ -> DirtyFlag
False
atomEvald :: Either RelationalError Atom
atomEvald = forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
env (RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupleIn GraphRefAtomExpr
atomExpr)
in
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall a. Eq a => a -> a -> DirtyFlag
/= AtomType
BoolAtomType then
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomType -> AtomType -> RelationalError
AtomTypeMismatchError AtomType
aType AtomType
BoolAtomType)
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\RelationTuple
tupleIn ->
case forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
renv (RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupleIn GraphRefAtomExpr
atomExpr) of
Left RelationalError
err -> forall a b. a -> Either a b
Left RelationalError
err
Right Atom
boolAtomValue -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom
boolAtomValue 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 forall a b. Either a b -> DirtyFlag
isRight (AttributeName -> Relation -> Either RelationalError Attribute
attributeForName AttributeName
attrName Relation
rel) then
forall a b. a -> Either a b
Left (AttributeName -> RelationalError
AttributeNameInUseError AttributeName
attrName)
else
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 -> 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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
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 <- forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tup GraphRefAtomExpr
atomExpr)
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 -> 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 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Just (Left RelationTuple
ctxtup) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ AttributeName -> RelationTuple -> Either RelationalError Atom
atomForAttributeName AttributeName
attrName RelationTuple
ctxtup
Just (Right Attributes
_) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Left RelationalError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
evalGraphRefAtomExpr RelationTuple
_ (NakedAtomExpr Atom
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 <- 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Function a -> [AtomType]
funcType AtomFunction
func) forall a. Num a => a -> a -> a
- Int
1
actualArgCount :: Int
actualArgCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length [AtomType]
argTypes
safeInit :: [a] -> [a]
safeInit [] = []
safeInit [a]
xs = forall a. [a] -> [a]
init [a]
xs
if Int
expectedArgCount forall a. Eq a => a -> a -> DirtyFlag
/= Int
actualArgCount then
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 = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
safeInit (forall a. Function a -> [AtomType]
funcType AtomFunction
func)) [AtomType]
argTypes
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(AtomType
expType, AtomType
actType) ->
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 <- 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 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomFunctionError -> RelationalError
AtomFunctionUserError AtomFunctionError
err)
Right Atom
result -> do
AtomType
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify (forall a. [a] -> a
last (forall a. Function a -> [AtomType]
funcType AtomFunction
func)) (Atom -> AtomType
atomTypeForAtom Atom
result))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
result
evalGraphRefAtomExpr RelationTuple
tupIn (RelationAtomExpr GraphRefRelationalExpr
relExpr) = do
GraphRefRelationalExprEnv
env <- forall r (m :: * -> *). MonadReader r m => m r
ask
let gfEnv :: GraphRefRelationalExprEnv
gfEnv = RelationTuple
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeTuplesIntoGraphRefRelationalExprEnv RelationTuple
tupIn GraphRefRelationalExprEnv
env
Relation
relAtom <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
relExpr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Relation -> Atom
RelationAtom Relation
relAtom)
evalGraphRefAtomExpr RelationTuple
_ (ConstructedAtomExpr AttributeName
tOrF [] GraphRefTransactionMarker
_)
| AttributeName
tOrF forall a. Eq a => a -> a -> DirtyFlag
== AttributeName
"True" = forall (f :: * -> *) a. Applicative f => a -> f a
pure (DirtyFlag -> Atom
BoolAtom DirtyFlag
True)
| AttributeName
tOrF forall a. Eq a => a -> a -> DirtyFlag
== AttributeName
"False" = 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 <- 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeEnv forall a b. (a -> b) -> a -> b
$
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
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 -> 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 -> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Atom -> AtomType
atomTypeForAtom Atom
atom)
Left RelationalError
_ ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Left RelationalError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
typeForGraphRefAtomExpr Attributes
_ (NakedAtomExpr Atom
atom) = 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 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 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right AtomFunction
func -> do
let funcRetType :: AtomType
funcRetType = forall a. [a] -> a
last (forall a. Function a -> [AtomType]
funcType AtomFunction
func)
funcArgTypes :: [AtomType]
funcArgTypes = forall a. [a] -> [a]
init (forall a. Function a -> [AtomType]
funcType AtomFunction
func)
funArgCount :: Int
funArgCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length [AtomType]
funcArgTypes
inArgCount :: Int
inArgCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length [GraphRefAtomExpr]
atomArgs
forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
when (Int
funArgCount forall a. Eq a => a -> a -> DirtyFlag
/= Int
inArgCount) (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Int -> Int -> RelationalError
FunctionArgumentCountMismatchError Int
funArgCount Int
inArgCount))
[AtomType]
argTypes <- 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
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) = 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 = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
fArg AtomType
arg) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` RelationalError -> GraphRefRelationalExprM AtomType
handler
) (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 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right TypeVarMap
tvMap ->
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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 <- 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)
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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DirtyFlag
`elem` [AttributeName
"True", AttributeName
"False"] =
forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomType
BoolAtomType
typeForGraphRefAtomExpr Attributes
attrs (ConstructedAtomExpr AttributeName
dConsName [GraphRefAtomExpr]
dConsArgs GraphRefTransactionMarker
tid) =
do
[AtomType]
argsTypes <- 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
tid
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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 -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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' forall a. Eq a => a -> a -> DirtyFlag
== Attributes
emptyAttributes then
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' -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err'
Right Attribute
attrType -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expectedType (Attribute -> AtomType
A.atomType Attribute
attrType)
Left RelationalError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
verifyGraphRefAtomExprTypes Relation
_ (NakedAtomExpr Atom
atom) AtomType
expectedType =
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ AttributeName
-> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName AttributeName
funcName' AtomFunctions
functions
let expectedArgTypes :: [AtomType]
expectedArgTypes = 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) = 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 = 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 forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` RelationalError -> GraphRefRelationalExprM AtomType
handler
[AtomType]
funcArgTypes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GraphRefAtomExpr, AtomType, Int)
-> GraphRefRelationalExprM AtomType
funcArgVerifier forall a b. (a -> b) -> a -> b
$ forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [GraphRefAtomExpr]
funcArgExprs [AtomType]
expectedArgTypes [Int
1..]
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [AtomType]
funcArgTypes forall a. Eq a => a -> a -> DirtyFlag
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [AtomType]
expectedArgTypes forall a. Num a => a -> a -> a
- Int
1 then
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([AtomType] -> [AtomType] -> RelationalError
AtomTypeCountError [AtomType]
funcArgTypes [AtomType]
expectedArgTypes)
else
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expectedType (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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
R.local GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergedAttrsEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
relationExpr)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ AtomType -> AtomType -> Either RelationalError AtomType
atomTypeVerify AtomType
expectedType AtomType
cType
evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute
evalGraphRefAttrExpr :: AttributeExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM Attribute
evalGraphRefAttrExpr (AttributeAndTypeNameExpr AttributeName
attrName TypeConstructor
tCons GraphRefTransactionMarker
transId) = do
TypeConstructorMapping
tConsMap <- DatabaseContext -> TypeConstructorMapping
typeConstructorMapping forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
transId
AtomType
aType <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ DirtyFlag
-> TypeConstructor
-> TypeConstructorMapping
-> TypeVarMap
-> Either RelationalError AtomType
atomTypeForTypeConstructorValidate DirtyFlag
True TypeConstructor
tCons TypeConstructorMapping
tConsMap forall k a. Map k a
M.empty
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ AtomType -> TypeConstructorMapping -> Either RelationalError ()
validateAtomType AtomType
aType TypeConstructorMapping
tConsMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AttributeName -> AtomType -> Attribute
Attribute AttributeName
attrName AtomType
aType
evalGraphRefAttrExpr (NakedAttributeExpr Attribute
attr) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
attr
evalGraphRefTupleExprs :: Maybe Attributes -> GraphRefTupleExprs -> GraphRefRelationalExprM [RelationTuple]
evalGraphRefTupleExprs :: Maybe Attributes
-> TupleExprsBase GraphRefTransactionMarker
-> GraphRefRelationalExprM [RelationTuple]
evalGraphRefTupleExprs Maybe Attributes
_ (TupleExprs GraphRefTransactionMarker
_ []) = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
evalGraphRefTupleExprs Maybe Attributes
mAttrs (TupleExprs GraphRefTransactionMarker
fixedMarker [TupleExprBase GraphRefTransactionMarker]
tupleExprL) = do
[RelationTuple]
tuples <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe Attributes
-> TupleExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM RelationTuple
evalGraphRefTupleExpr Maybe Attributes
mAttrs) [TupleExprBase GraphRefTransactionMarker]
tupleExprL
Attributes
finalAttrs <- case Maybe Attributes
mAttrs of
Just Attributes
attrs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Attributes
attrs
Maybe Attributes
Nothing ->
case [RelationTuple]
tuples of
[] -> 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 forall a. Eq a => a -> a -> DirtyFlag
== Attribute
accAttr then
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
accAttr
else
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ Attribute -> Attribute -> Either RelationalError Attribute
resolveAttributes Attribute
accAttr Attribute
tupAttr
[Attribute]
mostResolvedTypes <-
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 = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Vector a -> [a]
V.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> Vector Attribute
attributesVec forall a b. (a -> b) -> a -> b
$ RelationTuple -> Attributes
tupleAttributes RelationTuple
tup) [Attribute]
acc
accNames :: Set AttributeName
accNames = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ 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 = forall a. Ord a => Set a -> Set a -> Set a
S.union (forall a. Ord a => Set a -> Set a -> Set a
S.difference Set AttributeName
accNames Set AttributeName
tupNames) (forall a. Ord a => Set a -> Set a -> Set a
S.difference Set AttributeName
tupNames Set AttributeName
accNames)
forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> DirtyFlag
null Set AttributeName
attrNamesDiff) (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Set AttributeName -> RelationalError
AttributeNamesMismatchError Set AttributeName
attrNamesDiff))
[Attribute]
nextTupleAttrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 forall a. Eq a => a -> a -> DirtyFlag
== Attributes
A.emptyAttributes then
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Attribute]
nextTupleAttrs
else
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Attributes -> RelationalError
TupleAttributeTypeMismatchError Attributes
diff)
) (forall a. Vector a -> [a]
V.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> Vector Attribute
attributesVec forall a b. (a -> b) -> a -> b
$ RelationTuple -> Attributes
tupleAttributes RelationTuple
headTuple) [RelationTuple]
tailTuples
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Attribute] -> Attributes
A.attributesFromList [Attribute]
mostResolvedTypes)
TypeConstructorMapping
tConsMap <- case forall (f :: * -> *) (t :: * -> *).
(Foldable f, Foldable t) =>
f (t GraphRefTransactionMarker) -> SingularTransactionRef
singularTransactions [TupleExprBase GraphRefTransactionMarker]
tupleExprL of
SingularTransactionRef GraphRefTransactionMarker
commonTransId ->
DatabaseContext -> TypeConstructorMapping
typeConstructorMapping forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
commonTransId
SingularTransactionRef
NoTransactionsRef ->
DatabaseContext -> TypeConstructorMapping
typeConstructorMapping forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
fixedMarker
SingularTransactionRef
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
TupleExprsReferenceMultipleMarkersError
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ TypeConstructorMapping -> Attributes -> Either RelationalError ()
validateAttributes TypeConstructorMapping
tConsMap Attributes
finalAttrs
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
-> GraphRefRelationalExprM RelationTuple
evalGraphRefTupleExpr Maybe Attributes
mAttrs (TupleExpr Map AttributeName GraphRefAtomExpr
tupMap) = do
let attrs :: Attributes
attrs = 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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomType
unresolvedType
Right AtomType
typeHint -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AttributeName
attrName, Atom
newAtom, AtomType
resolvedType)
[(AttributeName, Atom, AtomType)]
attrAtoms <- 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 (forall k a. Map k a -> [(k, a)]
M.toList Map AttributeName GraphRefAtomExpr
tupMap)
let tupAttrs :: Attributes
tupAttrs = [Attribute] -> Attributes
A.attributesFromList forall a b. (a -> b) -> a -> b
$ 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 = forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> Maybe a -> a
fromMaybe Attributes
tupAttrs Maybe Attributes
mAttrs
forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
when (Attributes -> Set AttributeName
A.attributeNameSet Attributes
finalAttrs forall a. Eq a => a -> a -> DirtyFlag
/= Attributes -> Set AttributeName
A.attributeNameSet Attributes
tupAttrs) forall a b. (a -> b) -> a -> b
$ 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
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 TupleExprsBase GraphRefTransactionMarker
tupleExprs) = do
Maybe Attributes
mAttrs <- case Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrExprs of
Just [AttributeExprBase GraphRefTransactionMarker]
_ ->
forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attribute] -> Attributes
A.attributesFromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AttributeExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM Attribute
evalGraphRefAttrExpr (forall a. a -> Maybe a -> a
fromMaybe [] Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrExprs)
Maybe [AttributeExprBase GraphRefTransactionMarker]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
[RelationTuple]
tuples <- Maybe Attributes
-> TupleExprsBase GraphRefTransactionMarker
-> GraphRefRelationalExprM [RelationTuple]
evalGraphRefTupleExprs Maybe Attributes
mAttrs TupleExprsBase GraphRefTransactionMarker
tupleExprs
let attrs :: Attributes
attrs = forall a. a -> Maybe a -> a
fromMaybe Attributes
firstTupleAttrs Maybe Attributes
mAttrs
firstTupleAttrs :: Attributes
firstTupleAttrs = if forall (t :: * -> *) a. Foldable t => t a -> DirtyFlag
null [RelationTuple]
tuples then Attributes
A.emptyAttributes else RelationTuple -> Attributes
tupleAttributes (forall a. [a] -> a
head [RelationTuple]
tuples)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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) =
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation Attributes
attributeSet RelationTupleSet
tupleSet
evalGraphRefRelationalExpr (ExistingRelation Relation
rel) = 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 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 -> 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Relation
relA 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Relation
relA 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
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 forall a. Eq a => a -> a -> DirtyFlag
== TransactionId
U.nil =
forall a b. a -> Either a b
Left RelationalError
RootTransactionTraversalError
| forall a. Set a -> DirtyFlag
S.null Set Transaction
matchingTrans =
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TransactionId -> RelationalError
NoSuchTransactionError TransactionId
tid
| DirtyFlag
otherwise =
forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head (forall a. Set a -> [a]
S.toList Set Transaction
matchingTrans)
where
matchingTrans :: Set Transaction
matchingTrans = forall a. (a -> DirtyFlag) -> Set a -> Set a
S.filter (\(Transaction TransactionId
idMatch TransactionInfo
_ Schemas
_) -> TransactionId
idMatch 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
_) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ Attributes -> RelationTupleSet -> Either RelationalError Relation
mkRelation Attributes
attrs RelationTupleSet
emptyTupleSet
typeForGraphRefRelationalExpr (ExistingRelation Relation
rel) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes -> Relation
emptyRelationWithAttrs (Relation -> Attributes
attributes Relation
rel))
typeForGraphRefRelationalExpr (MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrExprs TupleExprsBase GraphRefTransactionMarker
tupleExprs) = do
Maybe Attributes
mAttrs <- case Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrExprs of
Just [AttributeExprBase GraphRefTransactionMarker]
attrExprs -> do
[Attribute]
attrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AttributeExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM Attribute
evalGraphRefAttributeExpr [AttributeExprBase GraphRefTransactionMarker]
attrExprs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ([Attribute] -> Attributes
attributesFromList [Attribute]
attrs))
Maybe [AttributeExprBase GraphRefTransactionMarker]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
[RelationTuple]
tuples <- Maybe Attributes
-> TupleExprsBase GraphRefTransactionMarker
-> GraphRefRelationalExprM [RelationTuple]
evalGraphRefTupleExprs Maybe Attributes
mAttrs TupleExprsBase GraphRefTransactionMarker
tupleExprs
let retAttrs :: Attributes
retAttrs = case [RelationTuple]
tuples of
(RelationTuple
tup:[RelationTuple]
_) -> RelationTuple -> Attributes
tupleAttributes RelationTuple
tup
[] -> forall a. a -> Maybe a -> a
fromMaybe Attributes
A.emptyAttributes Maybe Attributes
mAttrs
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
tid
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
rvName Map AttributeName GraphRefRelationalExpr
relVars of
Maybe GraphRefRelationalExpr
Nothing -> 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except 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'
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ RestrictionFilter -> Relation -> Either RelationalError Relation
restrict RestrictionFilter
filt Relation
expr'
typeForGraphRefRelationalExpr Equals{} =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
relationFalse
typeForGraphRefRelationalExpr NotEquals{} =
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 (forall a.
ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Extend GraphRefExtendTupleExpr
extendTupleExpr (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphRefTransactionMarker
-> GraphRefRelationalExprM DatabaseContext
gfDatabaseContextForMarker GraphRefTransactionMarker
tid
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
macroName Map AttributeName GraphRefRelationalExpr
rvs of
Just GraphRefRelationalExpr
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (AttributeName -> RelationalError
RelVarAlreadyDefinedError AttributeName
macroName)
Maybe GraphRefRelationalExpr
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WithNameExprBase GraphRefTransactionMarker
-> ReaderT
GraphRefRelationalExprEnv (ExceptT RelationalError Identity) ()
checkMacroName forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Ord a => [a] -> Set a
S.fromList (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 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right Attributes
attrs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => [a] -> Set a
S.fromList (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 (forall a. Set a -> DirtyFlag
S.null Set AttributeName
nonExistentAttributeNames) then
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Set AttributeName -> RelationalError
AttributeNamesMismatchError Set AttributeName
nonExistentAttributeNames
else
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
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
-> GraphRefRelationalExprM Attribute
evalGraphRefAttributeExpr (AttributeAndTypeNameExpr AttributeName
attrName TypeConstructor
tCons GraphRefTransactionMarker
tid) = do
TypeConstructorMapping
tConsMap <- DatabaseContext -> TypeConstructorMapping
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 forall k a. Map k a
M.empty of
Left RelationalError
err -> 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 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right ()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (AttributeName -> AtomType -> Attribute
Attribute AttributeName
attrName AtomType
aType)
evalGraphRefAttributeExpr (NakedAttributeExpr Attribute
attr) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
attr
mkEmptyRelVars :: RelationVariables -> RelationVariables
mkEmptyRelVars :: Map AttributeName GraphRefRelationalExpr
-> Map AttributeName GraphRefRelationalExpr
mkEmptyRelVars = forall a b k. (a -> b) -> Map k a -> Map k b
M.map 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
_) = forall a. Attributes -> RelationTupleSet -> RelationalExprBase a
MakeStaticRelation Attributes
attrs RelationTupleSet
emptyTupleSet
mkEmptyRelVar (ExistingRelation Relation
rel) = forall a. Relation -> RelationalExprBase a
ExistingRelation (Attributes -> Relation
emptyRelationWithAttrs (Relation -> Attributes
attributes Relation
rel))
mkEmptyRelVar rv :: RelationalExprBase a
rv@RelationVariable{} = forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate forall a. RestrictionPredicateExprBase a
TruePredicate) RelationalExprBase a
rv
mkEmptyRelVar (Project AttributeNamesBase a
attrNames RelationalExprBase a
expr) = 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) = 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) = 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) = 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) = 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) = 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) = 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) = 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) = 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) = 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) = 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) = forall a.
[(WithNameExprBase a, RelationalExprBase a)]
-> RelationalExprBase a -> RelationalExprBase a
With (forall a b. (a -> b) -> [a] -> [b]
map (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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (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 (forall a. a -> Maybe a
Just DatabaseContext
ctx) TransactionGraph
graph
Relation
gfType <- forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfExpr)
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 (forall a b. (a -> b) -> [a] -> [b]
map Attribute -> [Atom]
attrAtoms (forall a. Vector a -> [a]
V.toList Vector Attribute
attrl)) of
Left RelationalError
err -> forall a. HasCallStack => [Char] -> a
error ([Char]
"relationVariablesAsRelation pooped " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RelationalError
err)
Right Relation
rel -> Relation -> Atom
RelationAtom Relation
rel
[(AttributeName, Relation)]
rvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}.
(a, GraphRefRelationalExpr) -> Either RelationalError (a, Relation)
mkRvDesc (forall k a. Map k a -> [(k, a)]
M.toList Map AttributeName GraphRefRelationalExpr
relVars)
let tups :: [[Atom]]
tups = 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' = forall a. GraphRefTransactionMarker -> ProcessExprM a -> a
runProcessExprM GraphRefTransactionMarker
UncommittedContextMarker (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
expr)
gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (forall a. a -> Maybe a
Just DatabaseContext
context) TransactionGraph
graph
case forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr GraphRefRelationalExpr
expr') of
Left RelationalError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
Right Relation
rel -> 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 :: DatabaseContextEvalMonad DatabaseContext
getContext = DatabaseContextEvalMonad DatabaseContext
getStateContext
relVarByName :: DatabaseContextM m => RelVarName -> m GraphRefRelationalExpr
relVarByName :: forall (m :: * -> *).
DatabaseContextM m =>
AttributeName -> m GraphRefRelationalExpr
relVarByName AttributeName
rvName = do
Map AttributeName GraphRefRelationalExpr
relvars <- DatabaseContext -> Map AttributeName GraphRefRelationalExpr
relationVariables forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). DatabaseContextM m => m DatabaseContext
getContext
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
rvName Map AttributeName GraphRefRelationalExpr
relvars of
Maybe GraphRefRelationalExpr
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AttributeName -> RelationalError
RelVarNotDefinedError AttributeName
rvName)
Just GraphRefRelationalExpr
gfexpr -> 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 TupleExprsBase GraphRefTransactionMarker
tupleExprs) =
forall a.
Maybe [AttributeExprBase a]
-> TupleExprsBase a -> RelationalExprBase a
MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve TupleExprsBase GraphRefTransactionMarker
tupleExprs
resolve orig :: GraphRefRelationalExpr
orig@MakeStaticRelation{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
orig
resolve orig :: GraphRefRelationalExpr
orig@ExistingRelation{} = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatabaseContextEvalMonad DatabaseContext
getStateContext
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttributeName
rvName Map AttributeName GraphRefRelationalExpr
rvMap of
Maybe GraphRefRelationalExpr
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
orig
Just GraphRefRelationalExpr
resolvedRv -> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
resolvedRv
resolve orig :: GraphRefRelationalExpr
orig@RelationVariable{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefRelationalExpr
orig
resolve (Project AttributeNamesBase GraphRefTransactionMarker
attrNames GraphRefRelationalExpr
relExpr) = forall a.
AttributeNamesBase a
-> RelationalExprBase a -> RelationalExprBase a
Project forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
attrNames forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
relExpr
resolve (Union GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprB
resolve (Join GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprB
resolve (Rename AttributeName
attrA AttributeName
attrB GraphRefRelationalExpr
expr) = forall a.
AttributeName
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
Rename AttributeName
attrA AttributeName
attrB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
resolve (Difference GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Difference forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprB
resolve (Group AttributeNamesBase GraphRefTransactionMarker
namesA AttributeName
nameB GraphRefRelationalExpr
expr) = forall a.
AttributeNamesBase a
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
Group forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
namesA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure AttributeName
nameB forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
resolve (Ungroup AttributeName
nameA GraphRefRelationalExpr
expr) = forall {a}.
AttributeName -> RelationalExprBase a -> RelationalExprBase a
Ungroup AttributeName
nameA forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
resolve (Restrict RestrictionPredicateExprBase GraphRefTransactionMarker
restrictExpr GraphRefRelationalExpr
relExpr) = forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
restrictExpr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
relExpr
resolve (Equals GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Equals forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprB
resolve (NotEquals GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) = forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
NotEquals forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
exprB
resolve (Extend GraphRefExtendTupleExpr
extendExpr GraphRefRelationalExpr
relExpr) = forall a.
ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Extend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefExtendTupleExpr
extendExpr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
relExpr
resolve (With WithNameAssocs
withExprs GraphRefRelationalExpr
relExpr) = forall a.
[(WithNameExprBase a, RelationalExprBase a)]
-> RelationalExprBase a -> RelationalExprBase a
With forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(WithNameExprBase GraphRefTransactionMarker
nam, GraphRefRelationalExpr
expr) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve WithNameExprBase GraphRefTransactionMarker
nam forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr) WithNameAssocs
withExprs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
relExpr
instance ResolveGraphRefTransactionMarker GraphRefTupleExprs where
resolve :: TupleExprsBase GraphRefTransactionMarker
-> DatabaseContextEvalMonad
(TupleExprsBase GraphRefTransactionMarker)
resolve (TupleExprs GraphRefTransactionMarker
marker [TupleExprBase GraphRefTransactionMarker]
tupleExprs) =
forall a. a -> [TupleExprBase a] -> TupleExprsBase a
TupleExprs GraphRefTransactionMarker
marker forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve [TupleExprBase GraphRefTransactionMarker]
tupleExprs
instance ResolveGraphRefTransactionMarker GraphRefTupleExpr where
resolve :: TupleExprBase GraphRefTransactionMarker
-> DatabaseContextEvalMonad
(TupleExprBase GraphRefTransactionMarker)
resolve (TupleExpr Map AttributeName GraphRefAtomExpr
tupMap) = do
[(AttributeName, GraphRefAtomExpr)]
tupMap' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(AttributeName
attrName, GraphRefAtomExpr
expr) -> (,) AttributeName
attrName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
expr ) (forall k a. Map k a -> [(k, a)]
M.toList Map AttributeName GraphRefAtomExpr
tupMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Map AttributeName (AtomExprBase a) -> TupleExprBase a
TupleExpr (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(AttributeName, GraphRefAtomExpr)]
tupMap'))
instance ResolveGraphRefTransactionMarker GraphRefAttributeNames where
resolve :: AttributeNamesBase GraphRefTransactionMarker
-> DatabaseContextEvalMonad
(AttributeNamesBase GraphRefTransactionMarker)
resolve orig :: AttributeNamesBase GraphRefTransactionMarker
orig@AttributeNames{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure AttributeNamesBase GraphRefTransactionMarker
orig
resolve orig :: AttributeNamesBase GraphRefTransactionMarker
orig@InvertedAttributeNames{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure AttributeNamesBase GraphRefTransactionMarker
orig
resolve (UnionAttributeNames AttributeNamesBase GraphRefTransactionMarker
namesA AttributeNamesBase GraphRefTransactionMarker
namesB) = forall a.
AttributeNamesBase a
-> AttributeNamesBase a -> AttributeNamesBase a
UnionAttributeNames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
namesA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
namesB
resolve (IntersectAttributeNames AttributeNamesBase GraphRefTransactionMarker
namesA AttributeNamesBase GraphRefTransactionMarker
namesB) = forall a.
AttributeNamesBase a
-> AttributeNamesBase a -> AttributeNamesBase a
IntersectAttributeNames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
namesA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve AttributeNamesBase GraphRefTransactionMarker
namesB
resolve (RelationalExprAttributeNames GraphRefRelationalExpr
expr) = forall a. RelationalExprBase a -> AttributeNamesBase a
RelationalExprAttributeNames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
instance ResolveGraphRefTransactionMarker GraphRefRestrictionPredicateExpr where
resolve :: RestrictionPredicateExprBase GraphRefTransactionMarker
-> DatabaseContextEvalMonad
(RestrictionPredicateExprBase GraphRefTransactionMarker)
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
TruePredicate = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. RestrictionPredicateExprBase a
TruePredicate
resolve (AndPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
exprA RestrictionPredicateExprBase GraphRefTransactionMarker
exprB) = forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
AndPredicate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
exprA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
exprB
resolve (OrPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
exprA RestrictionPredicateExprBase GraphRefTransactionMarker
exprB) = forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
OrPredicate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
exprA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
exprB
resolve (NotPredicate RestrictionPredicateExprBase GraphRefTransactionMarker
expr) = forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve RestrictionPredicateExprBase GraphRefTransactionMarker
expr
resolve (RelationalExprPredicate GraphRefRelationalExpr
expr) = forall a. RelationalExprBase a -> RestrictionPredicateExprBase a
RelationalExprPredicate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
resolve (AtomExprPredicate GraphRefAtomExpr
expr) = forall a. AtomExprBase a -> RestrictionPredicateExprBase a
AtomExprPredicate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
expr
resolve (AttributeEqualityPredicate AttributeName
nam GraphRefAtomExpr
expr)= forall a.
AttributeName -> AtomExprBase a -> RestrictionPredicateExprBase a
AttributeEqualityPredicate AttributeName
nam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
expr
instance ResolveGraphRefTransactionMarker GraphRefExtendTupleExpr where
resolve :: GraphRefExtendTupleExpr
-> DatabaseContextEvalMonad GraphRefExtendTupleExpr
resolve (AttributeExtendTupleExpr AttributeName
nam GraphRefAtomExpr
atomExpr) = forall a. AttributeName -> AtomExprBase a -> ExtendTupleExprBase a
AttributeExtendTupleExpr AttributeName
nam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
atomExpr
instance ResolveGraphRefTransactionMarker GraphRefWithNameExpr where
resolve :: WithNameExprBase GraphRefTransactionMarker
-> DatabaseContextEvalMonad
(WithNameExprBase GraphRefTransactionMarker)
resolve orig :: WithNameExprBase GraphRefTransactionMarker
orig@WithNameExpr{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure WithNameExprBase GraphRefTransactionMarker
orig
instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where
resolve :: GraphRefAtomExpr -> DatabaseContextEvalMonad GraphRefAtomExpr
resolve orig :: GraphRefAtomExpr
orig@AttributeAtomExpr{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefAtomExpr
orig
resolve orig :: GraphRefAtomExpr
orig@NakedAtomExpr{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefAtomExpr
orig
resolve (FunctionAtomExpr AttributeName
nam [GraphRefAtomExpr]
atomExprs GraphRefTransactionMarker
marker) =
forall a. AttributeName -> [AtomExprBase a] -> a -> AtomExprBase a
FunctionAtomExpr AttributeName
nam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve [GraphRefAtomExpr]
atomExprs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefTransactionMarker
marker
resolve (RelationAtomExpr GraphRefRelationalExpr
expr) = forall a. RelationalExprBase a -> AtomExprBase a
RelationAtomExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefRelationalExpr
expr
resolve (ConstructedAtomExpr AttributeName
dConsName [GraphRefAtomExpr]
atomExprs GraphRefTransactionMarker
marker) =
forall a. AttributeName -> [AtomExprBase a] -> a -> AtomExprBase a
ConstructedAtomExpr AttributeName
dConsName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve [GraphRefAtomExpr]
atomExprs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphRefTransactionMarker
marker
applyUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr
applyUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr
applyUnionCollapse = forall t a. Recursive t => (Base t a -> a) -> t -> a
Fold.cata RelationalExprBaseF
GraphRefTransactionMarker GraphRefRelationalExpr
-> GraphRefRelationalExpr
opt
where
opt :: RelationalExprBaseF GraphRefTransactionMarker GraphRefRelationalExpr -> GraphRefRelationalExpr
opt :: RelationalExprBaseF
GraphRefTransactionMarker GraphRefRelationalExpr
-> GraphRefRelationalExpr
opt (UnionF GraphRefRelationalExpr
exprA GraphRefRelationalExpr
exprB) | GraphRefRelationalExpr
exprA forall a. Eq a => a -> a -> DirtyFlag
== GraphRefRelationalExpr
exprB = GraphRefRelationalExpr
exprA
opt (UnionF
exprA :: GraphRefRelationalExpr
exprA@(MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs1 TupleExprsBase GraphRefTransactionMarker
tupExprs1)
exprB :: GraphRefRelationalExpr
exprB@(MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs2 TupleExprsBase GraphRefTransactionMarker
tupExprs2)) | TupleExprsBase GraphRefTransactionMarker
tupExprs1 forall a. Eq a => a -> a -> DirtyFlag
== TupleExprsBase GraphRefTransactionMarker
tupExprs2 = forall a.
Maybe [AttributeExprBase a]
-> TupleExprsBase a -> RelationalExprBase a
MakeRelationFromExprs (Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe [AttributeExprBase GraphRefTransactionMarker]
mAttrs2) TupleExprsBase GraphRefTransactionMarker
tupExprs1
| forall {a}. TupleExprsBase a -> DirtyFlag
tupExprsNull TupleExprsBase GraphRefTransactionMarker
tupExprs1 = GraphRefRelationalExpr
exprB
| forall {a}. TupleExprsBase a -> DirtyFlag
tupExprsNull TupleExprsBase GraphRefTransactionMarker
tupExprs2 = GraphRefRelationalExpr
exprA
opt RelationalExprBaseF
GraphRefTransactionMarker GraphRefRelationalExpr
x = forall t. Corecursive t => Base t t -> t
Fold.embed 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 forall a. Eq a => a -> a -> DirtyFlag
== RestrictionPredicateExprBase GraphRefTransactionMarker
npred' -> GraphRefRelationalExpr
orig'
GraphRefRelationalExpr
_ -> GraphRefRelationalExpr
orig
applyRestrictionCollapse GraphRefRelationalExpr
expr = GraphRefRelationalExpr
expr