{-# 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 (foldM, unless, when, forM_)
import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError, catchError)
import Control.Monad.Reader (ReaderT, runReaderT, asks, ask, local)
import qualified Control.Monad.Reader as R
import Control.Monad.State (gets, get, put)
import Control.Monad.Trans.Class (lift)
import Control.Monad.IO.Class (liftIO)
import Data.Bifunctor (second)
import Data.Maybe
import Data.Tuple (swap)
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.Trans.Except (except)
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
      
-- | Used to start a fresh database state for a new database context expression.
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
  } --future work: propagate return accumulator

-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
data RelationalExprEnv = RelationalExprEnv {
  RelationalExprEnv -> DatabaseContext
re_context :: DatabaseContext, 
  RelationalExprEnv -> TransactionGraph
re_graph :: TransactionGraph,
  RelationalExprEnv -> Maybe (Either RelationTuple Attributes)
re_extra :: 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)

--used to eval relationalexpr
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, --new, alterable context for a new transaction
  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}) 

-- | The context is optionally passed down along in cases where the current context is uncommitted.
data GraphRefRelationalExprEnv =
  GraphRefRelationalExprEnv {
  GraphRefRelationalExprEnv -> Maybe DatabaseContext
gre_context :: Maybe DatabaseContext,
  GraphRefRelationalExprEnv -> TransactionGraph
gre_graph :: TransactionGraph,
  GraphRefRelationalExprEnv
-> Maybe (Either RelationTuple Attributes)
gre_extra :: 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 }

--helper function to process relation variable creation/assignment
setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar :: AttributeName
-> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
setRelVar AttributeName
relVarName GraphRefRelationalExpr
relExpr = do
  DatabaseContext
currentContext <- DatabaseContextEvalMonad DatabaseContext
getStateContext
  --prevent recursive relvar definition by resolving references to relvars in previous states
  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 }
  --optimization: if the relexpr is unchanged, skip the update      
  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
    --determine when to check constraints
    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

--fast-path insertion- we already know that the previous relvar validated correctly, so we can validate just the relation that is being inserted for attribute matches- without this, even a single tuple relation inserted causes the entire relation to be re-validated unnecessarily
--insertIntoRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()

-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation
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

  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 -> do
      -- if we are targeting an existing rv, we can morph a MakeRelationFromExprs datum to fill in missing type variables'
          let hintedExpr :: GraphRefRelationalExpr
hintedExpr = Attributes -> GraphRefRelationalExpr -> GraphRefRelationalExpr
addTargetTypeHints (Relation -> Attributes
attributes Relation
expectedType) GraphRefRelationalExpr
expr
              eNewExprType :: Either RelationalError Relation
eNewExprType = forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
reEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
hintedExpr)
          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
hintedExpr 
              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
  
--union of restricted+updated portion and the unrestricted+unupdated portion
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
  --get the current attributes name in the relvar to ensure that we don't conflict when renaming
      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.
Set (AttributeName, AttributeName)
-> RelationalExprBase a -> RelationalExprBase a
Rename (forall a. a -> Set a
S.singleton (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)
              -- the atomExprMap could reference other attributes, so we must perform multi-pass folds
      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 }
      -- if the potential context passes all constraints, then save it
      -- potential optimization: validate only the new constraint- all old constraints must already hold
      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 }
    
-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
evalGraphRefDatabaseContextExpr (AddNotification AttributeName
notName RelationalExpr
triggerExpr RelationalExpr
resultOldExpr RelationalExpr
resultNewExpr) = do
  DatabaseContext
currentContext <- DatabaseContextEvalMonad DatabaseContext
getStateContext
  TransactionGraph
graph <- DatabaseContextEvalMonad TransactionGraph
dbcGraph
  TransactionId
transId <- DatabaseContextEvalMonad TransactionId
dbcTransId
  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 newNotification :: Notification
newNotification = Notification { changeExpr :: RelationalExpr
changeExpr = RelationalExpr
triggerExpr,
                                           reportOldExpr :: RelationalExpr
reportOldExpr = RelationalExpr
resultOldExpr, 
                                           reportNewExpr :: RelationalExpr
reportNewExpr = RelationalExpr
resultNewExpr}
          newNotifications :: Notifications
newNotifications = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AttributeName
notName Notification
newNotification Notifications
nots
          potentialContext :: DatabaseContext
potentialContext = DatabaseContext
currentContext { notifications :: Notifications
notifications = Notifications
newNotifications }
      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 (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 }


-- | Adds type and data constructors to the database context.
-- validate that the type *and* constructor names are unique! not yet implemented!
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
  -- validate that the constructor's types exist
  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 }

-- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive.
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) =
  --the multiple expressions must pass the same context around- not the old unmodified context
  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
  --resolve atom arguments
  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 
          --check that the atom types are valid
          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 -- ^ when running in persistent mode, this must be a Just value to a directory containing .o/.so/.dynlib files which the user has placed there for access to compiled functions
  }

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
            --compile the function
            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 }
               -- check if the name is already in use
                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
      --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
      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
              --if we are here, we have validated that the written function type is X -> DatabaseContext -> DatabaseContext, so we need to munge the first elements into an array
              [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
                    }
                -- check if the name is already in use
              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

  -- when running an in-memory database, we are willing to load object files from any path- when running in persistent mode, we load modules only from the modules directory so that we can be reasonbly sure that these same modules will exist when the database is restarted from the same directory
  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
  --Define
  DatabaseContext
currentContext <- DatabaseContextIOEvalMonad DatabaseContext
getDBCIOContext
  DatabaseContextIOEvalEnv
env <- forall r (m :: * -> *). MonadReader r m => m r
RWS.ask
  --create graph ref expr
  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
         --Assign
           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')

--run verification on all constraints
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))
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AttributeName, Notification) -> Either RelationalError ()
checkNotification (forall k a. Map k a -> [(k, a)]
M.toList (DatabaseContext -> Notifications
notifications 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
      -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment
    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)
      --if both expressions are of a single-attribute (such as with a simple foreign key), the names of the attributes are irrelevant (they need not match) because the expression is unambiguous, but special-casing this to rename the attribute automatically would not be orthogonal behavior and probably cause confusion. Instead, special case the error to make it clear.
          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)
    --registered queries just need to typecheck- think of them as a constraints on the schema/DDL
    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 ()
    checkRelExpr :: RelationalExpr -> Either RelationalError Relation
checkRelExpr RelationalExpr
relExpr = do
      let gfExpr :: GraphRefRelationalExpr
gfExpr = forall {a}. ProcessExprM a -> a
process (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
relExpr)
      forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfExpr)
    checkNotification :: (AttributeName, Notification) -> Either RelationalError ()
checkNotification (AttributeName
notName, Notification
notif) = do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(NotificationExpression
NotificationChangeExpression, Notification -> RelationalExpr
changeExpr Notification
notif),
             (NotificationExpression
NotificationReportOldExpression, Notification -> RelationalExpr
reportOldExpr Notification
notif),
             (NotificationExpression
NotificationReportNewExpression, Notification -> RelationalExpr
reportNewExpr Notification
notif)] forall a b. (a -> b) -> a -> b
$
        \(NotificationExpression
typ, RelationalExpr
relExpr) -> do
          case RelationalExpr -> Either RelationalError Relation
checkRelExpr RelationalExpr
relExpr of
            Left RelationalError
err -> forall a b. a -> Either a b
Left (AttributeName
-> NotificationExpression -> RelationalError -> RelationalError
NotificationValidationError AttributeName
notName NotificationExpression
typ RelationalError
err)
            Right Relation
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      

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

typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation
typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation
typeForRelationalExpr RelationalExpr
expr = do
  --replace the relationVariables context element with a cloned set of relation devoid of tuples
  --evalRelationalExpr could still return an existing relation with tuples, so strip them
  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

{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
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)

--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here
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 do
      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
-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
predicateRestrictionFilter Attributes
attrs (AtomExprPredicate GraphRefAtomExpr
atomExpr) = do
  --merge attrs into the state attributes
  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) = 
--  renv <- askEnv
  -- check that the attribute name is not in use
  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
-- first argumentr is starting value, second argument is relationatom
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 [] = [] -- different behavior from normal init
      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
          --validate that the result matches the expected type
          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
  --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes
  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
tupIn (SubrelationAttributeAtomExpr AttributeName
relAttr AttributeName
subAttr) = do
  Atom
atom <- RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupIn (forall a. AttributeName -> AtomExprBase a
AttributeAtomExpr AttributeName
relAttr)
  case Atom
atom of
    RelationAtom Relation
rel ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Relation -> AttributeName -> Atom
SubrelationFoldAtom Relation
rel AttributeName
subAttr)
    Atom
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AttributeName -> RelationalError
AttributeIsNotRelationValuedError AttributeName
relAttr)
evalGraphRefAtomExpr RelationTuple
tupIn (IfThenAtomExpr GraphRefAtomExpr
ifExpr GraphRefAtomExpr
thenExpr GraphRefAtomExpr
elseExpr) = do
  Atom
conditional <- RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupIn GraphRefAtomExpr
ifExpr
  case Atom
conditional of
    BoolAtom DirtyFlag
True -> RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupIn GraphRefAtomExpr
thenExpr
    BoolAtom DirtyFlag
False -> RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom
evalGraphRefAtomExpr RelationTuple
tupIn GraphRefAtomExpr
elseExpr
    Atom
otherAtom -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomType -> RelationalError
IfThenExprExpectedBooleanError (Atom -> AtomType
atomTypeForAtom Atom
otherAtom))
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 --why is the tid unused here? suspicious
  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
attrs (SubrelationAttributeAtomExpr AttributeName
relAttr AttributeName
subAttr) = do
  AtomType
relType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
attrs (forall a. AttributeName -> AtomExprBase a
AttributeAtomExpr AttributeName
relAttr)
  case AtomType
relType of
    RelationAtomType Attributes
relAttrs -> 
      case AttributeName -> Attributes -> Either RelationalError AtomType
A.atomTypeForAttributeName AttributeName
subAttr Attributes
relAttrs of
        Left RelationalError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RelationalError
err
        Right AtomType
attrType -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtomType -> AtomType
SubrelationFoldAtomType AtomType
attrType)
    AtomType
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AttributeName -> RelationalError
AttributeIsNotRelationValuedError AttributeName
relAttr)
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) = do
                      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
attrs (IfThenAtomExpr GraphRefAtomExpr
ifExpr GraphRefAtomExpr
thenExpr GraphRefAtomExpr
elseExpr) = do
  -- ifExpr must be BoolAtomType
  AtomType
ifType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
attrs GraphRefAtomExpr
ifExpr
  forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
when (AtomType
ifType forall a. Eq a => a -> a -> DirtyFlag
/= AtomType
BoolAtomType) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomType -> RelationalError
IfThenExprExpectedBooleanError AtomType
ifType)
  -- thenExpr and elseExpr must return the same type
  AtomType
thenType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
attrs GraphRefAtomExpr
thenExpr
  AtomType
elseType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr Attributes
attrs GraphRefAtomExpr
elseExpr
  forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
when (AtomType
thenType forall a. Eq a => a -> a -> DirtyFlag
/= AtomType
elseType) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomType -> AtomType -> RelationalError
AtomTypeMismatchError AtomType
thenType AtomType
elseType)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure AtomType
thenType
-- grab the type of the data constructor, then validate that the args match the expected types
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

-- | Validate that the type of the AtomExpr matches the expected type.
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 (SubrelationAttributeAtomExpr AttributeName
relAttr AttributeName
subAttr) AtomType
expectedType = do
    let mergedAttrsEnv :: GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergedAttrsEnv = Attributes
-> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergeAttributesIntoGraphRefRelationalExprEnv (Relation -> Attributes
attributes Relation
relIn)
    (Relation Attributes
relAttrs RelationTupleSet
_) <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
R.local GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
mergedAttrsEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr (forall a. AttributeName -> RelationalExprBase a
RelationValuedAttribute AttributeName
relAttr))
    AtomType
subAttrType <- 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 -> Attributes -> Either RelationalError AtomType
A.atomTypeForAttributeName AttributeName
subAttr Attributes
relAttrs
    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 -> AtomType
SubrelationFoldAtomType AtomType
subAttrType)
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) = do
              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
relIn (IfThenAtomExpr GraphRefAtomExpr
_ifExpr GraphRefAtomExpr
thenExpr GraphRefAtomExpr
elseExpr) AtomType
expectedType = do
  AtomType
thenType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr (Relation -> Attributes
attributes Relation
relIn) GraphRefAtomExpr
thenExpr
  AtomType
elseType <- Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
typeForGraphRefAtomExpr (Relation -> Attributes
attributes Relation
relIn) GraphRefAtomExpr
elseExpr
  forall (f :: * -> *). Applicative f => DirtyFlag -> f () -> f ()
when (AtomType
thenType forall a. Eq a => a -> a -> DirtyFlag
/= AtomType
elseType) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomType -> AtomType -> RelationalError
AtomTypeMismatchError AtomType
thenType AtomType
elseType)  
  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
thenType
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

-- | Look up the type's name and create a new attribute.
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

-- for tuple type concrete resolution (Nothing ==> Maybe Int) when the attributes hint is Nothing, we need to first process all the tuples, then extract the concrete types on a per-attribute basis, then reprocess the tuples to include the concrete types
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
      --gather up resolved atom types or throw an error if an attribute cannot be made concrete from the inferred types- this could still fail if the type cannot be inferred (e.g. from [Nothing, Nothing])
          let 
              processTupleAttrs :: (Attribute, Attribute) -> t (ExceptT RelationalError m) Attribute
processTupleAttrs (Attribute
tupAttr, Attribute
accAttr) =
                --if the attribute is a constructedatomtype, we can recurse into it to potentially resolve type variables                
                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)
  --strategy: if all the tuple expr transaction markers refer to one location, then we can pass the type constructor mapping from that location, otherwise, we cannot assume that the types are the same
  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
  -- if there are multiple transaction markers in the TupleExprs, then we can't assume a single type constructor mapping- this could be improved in the future, but if all the tuples are fully resolved, then we don't need further resolution                     
                   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


--resolveAttributes (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",IntegerAtomType),("b",TypeVariableType "b")]))) (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",TypeVariableType "a"),("b",TextAtomType)])))
                                                                                                                                                 
evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple
evalGraphRefTupleExpr :: Maybe Attributes
-> TupleExprBase GraphRefTransactionMarker
-> GraphRefRelationalExprM RelationTuple
evalGraphRefTupleExpr Maybe Attributes
mAttrs (TupleExpr Map AttributeName GraphRefAtomExpr
tupMap) = do
  -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority
  -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed
  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
          --provided when the relation header is available
          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
                          --resolve atom typevars based on resolvedType?
          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
    --verify that the attributes match
  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
$ do
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Attributes -> RelationalError
TupleAttributeTypeMismatchError Attributes
tupAttrs)
  --we can't resolve types here- they have to be resolved at the atom level where the graph ref is held
  --tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))
  let tup' :: RelationTuple
tup' = Attributes -> RelationTuple -> RelationTuple
reorderTuple Attributes
finalAttrs RelationTuple
tup
  --TODO: restore type resolution
--  _ <- lift $ except (validateTuple tup' tConss)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure RelationTuple
tup'

--temporary implementation until we have a proper planner+executor
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 = case [RelationTuple]
tuples of
        [] -> Attributes
A.emptyAttributes
        RelationTuple
x : [RelationTuple]
_ -> RelationTuple -> Attributes
tupleAttributes RelationTuple
x
  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 (RelationValuedAttribute AttributeName
attrName) = 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 (Set AttributeName -> RelationalError
NoSuchAttributeNamesError (forall a. a -> Set a
S.singleton AttributeName
attrName))
    Just (Left RelationTuple
ctxtup) -> do
      Atom
atom <- 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
      case Atom
atom of
        RelationAtom Relation
rel -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Relation
rel
        Atom
other -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomType -> AtomType -> RelationalError
AtomTypeMismatchError (Attributes -> AtomType
RelationAtomType forall a. Monoid a => a
mempty) (Atom -> AtomType
atomTypeForAtom Atom
other))
    Just (Right Attributes
_) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Set AttributeName -> RelationalError
NoSuchAttributeNamesError (forall a. a -> Set a
S.singleton AttributeName
attrName))
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 Set (AttributeName, AttributeName)
attrsSet 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
$ Set (AttributeName, AttributeName)
-> Relation -> Either RelationalError Relation
renameMany Set (AttributeName, AttributeName)
attrsSet 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{} =
  --strategy A: add relation variables to the contexts in the graph
  --strategy B: drop in macros in place (easier programmatically)
  --strategy B implementation
  GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
evalGraphRefRelationalExpr (GraphRefWithNameAssocs
-> 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
  | DirtyFlag
otherwise =
      let sameTID :: Transaction -> DirtyFlag
sameTID (Transaction TransactionId
idMatch TransactionInfo
_ Schemas
_) = TransactionId
idMatch forall a. Eq a => a -> a -> DirtyFlag
== TransactionId
tid
          matchingTrans :: Set Transaction
matchingTrans = forall a. (a -> DirtyFlag) -> Set a -> Set a
S.filter Transaction -> DirtyFlag
sameTID forall a b. (a -> b) -> a -> b
$ TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graph
      in  case forall a. Set a -> [a]
S.toList Set Transaction
matchingTrans of
        [] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TransactionId -> RelationalError
NoSuchTransactionError TransactionId
tid
        Transaction
x : [Transaction]
_ -> forall a b. b -> Either a b
Right Transaction
x

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 (RelationValuedAttribute AttributeName
attrName) = 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 (Set AttributeName -> RelationalError
NoSuchAttributeNamesError (forall a. a -> Set a
S.singleton AttributeName
attrName)) -- or can this be an attribute at the top-level?
    Just (Left RelationTuple
ctxtup) -> do
      Atom
atom <- 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
      case Atom
atom of
        RelationAtom Relation
rel -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes -> Relation
emptyRelationWithAttrs (Relation -> Attributes
attributes Relation
rel))
        Atom
other -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomType -> AtomType -> RelationalError
AtomTypeMismatchError (Attributes -> AtomType
RelationAtomType forall a. Monoid a => a
mempty) (Atom -> AtomType
atomTypeForAtom Atom
other))
    Just (Right Attributes
attrs) -> do
      case AttributeName -> Attributes -> Either RelationalError AtomType
A.atomTypeForAttributeName AttributeName
attrName Attributes
attrs of
        Left{} -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Set AttributeName -> RelationalError
NoSuchAttributeNamesError (forall a. a -> Set a
S.singleton AttributeName
attrName))
        Right AtomType
typ -> do
          case AtomType
typ of
            RelationAtomType Attributes
relAttrs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Attributes -> Relation
emptyRelationWithAttrs Attributes
relAttrs
            AtomType
other -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AtomType -> AtomType -> RelationalError
AtomTypeMismatchError (Attributes -> AtomType
RelationAtomType Attributes
A.emptyAttributes) AtomType
other)
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 Set (AttributeName, AttributeName)
attrs 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
$ Set (AttributeName, AttributeName)
-> Relation -> Either RelationalError Relation
renameMany Set (AttributeName, AttributeName)
attrs 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 GraphRefWithNameAssocs
withs GraphRefRelationalExpr
_) = do
  let expr' :: GraphRefRelationalExpr
expr' = GraphRefWithNameAssocs
-> 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) --this error does not include the transaction marker, but should be good enough to identify the cause
          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) GraphRefWithNameAssocs
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 --do not truncate here because we might lose essential type information in emptying the tuples
    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 x :: RelationalExprBase a
x@RelationValuedAttribute{} = RelationalExprBase a
x
    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 Set (AttributeName, AttributeName)
attrs RelationalExprBase a
expr) = forall a.
Set (AttributeName, AttributeName)
-> RelationalExprBase a -> RelationalExprBase a
Rename Set (AttributeName, AttributeName)
attrs (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 WithNamesAssocsBase a
macros RelationalExprBase a
expr) = forall a.
WithNamesAssocsBase 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) WithNamesAssocsBase 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))
      
-- | Return a Relation describing the relation variables.
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

-- | An unoptimized variant of evalGraphRefRelationalExpr for testing.
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
  
-- | resolve UncommittedTransactionMarker whenever possible- this is important in the DatabaseContext in order to mitigate self-referencing loops for updates
class ResolveGraphRefTransactionMarker a where
  resolve :: a -> DatabaseContextEvalMonad a

-- s := s union t
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@RelationValuedAttribute{} = 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 Set (AttributeName, AttributeName)
attrs GraphRefRelationalExpr
expr) = forall a.
Set (AttributeName, AttributeName)
-> RelationalExprBase a -> RelationalExprBase a
Rename Set (AttributeName, AttributeName)
attrs 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 GraphRefWithNameAssocs
withExprs GraphRefRelationalExpr
relExpr) = forall a.
WithNamesAssocsBase 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) GraphRefWithNameAssocs
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 -- match uncommitted marker?

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@SubrelationAttributeAtomExpr{} = 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 (IfThenAtomExpr GraphRefAtomExpr
ifExpr GraphRefAtomExpr
thenExpr GraphRefAtomExpr
elseExpr) = forall a.
AtomExprBase a
-> AtomExprBase a -> AtomExprBase a -> AtomExprBase a
IfThenAtomExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
ifExpr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
thenExpr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ResolveGraphRefTransactionMarker a =>
a -> DatabaseContextEvalMonad a
resolve GraphRefAtomExpr
elseExpr
  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

--convert series of simple Union queries into MakeStaticRelation
-- this is especially useful for long, nested applications of Union with simple tuples
-- Union (MakeRelation x y) (MakeRelation x y') -> MakeRelation x (y + y')

--MakeRelationFromExprs Nothing (TupleExprs UncommittedContextMarker [TupleExpr (fromList [("name", NakedAtomExpr (TextAtom "steve"))])])

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


--UPDATE optimization- find matching where clause in "lower" levels of renaming
--update x where y=1 set (x:=5,z:=10); update x where y=1 set(x:=6,z:=11)
-- =>
-- update x where y=1 set (x:=6,z:=11)
-- future opt: match individual attributes update x where y=1 set (x:=5); update x where y=1 set (z:=11) => update x where y=1 set (x:=5,z:=11)

--strategy: try to collapse the top-level update (union (restrict pred MakeRelationFromExpr) expr) if it contains the same predicate and resultant relation

--DELETE optimization
-- if a restriction matches a previous restriction, combine them
-- O(1) since it only scans at the top level, critical in benchmarks generating redundant deletions
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

firstAtomForAttributeName :: AttributeName -> [RelationTuple] -> GraphRefRelationalExprM Atom
firstAtomForAttributeName :: AttributeName -> [RelationTuple] -> GraphRefRelationalExprM Atom
firstAtomForAttributeName AttributeName
attrName [RelationTuple]
tuples = do
  let folder :: RelationTuple -> Maybe Atom -> Maybe Atom
folder RelationTuple
tup Maybe Atom
acc =
        case AttributeName -> RelationTuple -> Either RelationalError Atom
atomForAttributeName AttributeName
attrName RelationTuple
tup of
          Left{} -> Maybe Atom
acc
          Right Atom
atom -> forall a. a -> Maybe a
Just Atom
atom
  case forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RelationTuple -> Maybe Atom -> Maybe Atom
folder forall a. Maybe a
Nothing [RelationTuple]
tuples of
    Maybe Atom
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Set AttributeName -> RelationalError
NoSuchAttributeNamesError (forall a. a -> Set a
S.singleton AttributeName
attrName))
    Just Atom
match -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
match

-- | Optionally add type hints to resolve type variables. For example, if we are inserting into a known relvar, then we have its concrete type.    
addTargetTypeHints :: Attributes -> GraphRefRelationalExpr -> GraphRefRelationalExpr
addTargetTypeHints :: Attributes -> GraphRefRelationalExpr -> GraphRefRelationalExpr
addTargetTypeHints Attributes
targetAttrs GraphRefRelationalExpr
expr =
  case GraphRefRelationalExpr
expr of
    MakeRelationFromExprs Maybe [AttributeExprBase GraphRefTransactionMarker]
Nothing TupleExprsBase GraphRefTransactionMarker
tupExprs ->
      forall a.
Maybe [AttributeExprBase a]
-> TupleExprsBase a -> RelationalExprBase a
MakeRelationFromExprs (forall a. a -> Maybe a
Just forall {a}. [AttributeExprBase a]
targetAttrExprs) TupleExprsBase GraphRefTransactionMarker
tupExprs
    Project AttributeNamesBase GraphRefTransactionMarker
attrs GraphRefRelationalExpr
e ->
      forall a.
AttributeNamesBase a
-> RelationalExprBase a -> RelationalExprBase a
Project AttributeNamesBase GraphRefTransactionMarker
attrs (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
e)
    Union GraphRefRelationalExpr
a GraphRefRelationalExpr
b ->
      forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
a) (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
b)
    Join GraphRefRelationalExpr
a GraphRefRelationalExpr
b ->
      forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Join (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
a) (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
b)
    Rename Set (AttributeName, AttributeName)
rens GraphRefRelationalExpr
e ->
      let renamedAttrs :: Attributes
renamedAttrs = Set (AttributeName, AttributeName) -> Attributes -> Attributes
A.renameAttributes' (forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map forall a b. (a, b) -> (b, a)
swap Set (AttributeName, AttributeName)
rens) Attributes
targetAttrs in
      forall a.
Set (AttributeName, AttributeName)
-> RelationalExprBase a -> RelationalExprBase a
Rename Set (AttributeName, AttributeName)
rens (Attributes -> GraphRefRelationalExpr -> GraphRefRelationalExpr
addTargetTypeHints Attributes
renamedAttrs GraphRefRelationalExpr
e)
    Difference GraphRefRelationalExpr
a GraphRefRelationalExpr
b ->
      forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Difference (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
a) (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
b)
    Group AttributeNamesBase GraphRefTransactionMarker
attrs AttributeName
gname GraphRefRelationalExpr
e ->
      forall a.
AttributeNamesBase a
-> AttributeName -> RelationalExprBase a -> RelationalExprBase a
Group AttributeNamesBase GraphRefTransactionMarker
attrs AttributeName
gname (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
e)
    Ungroup AttributeName
gname GraphRefRelationalExpr
e ->
      forall {a}.
AttributeName -> RelationalExprBase a -> RelationalExprBase a
Ungroup AttributeName
gname (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
e)
    Restrict RestrictionPredicateExprBase GraphRefTransactionMarker
restriction GraphRefRelationalExpr
e ->
      forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict RestrictionPredicateExprBase GraphRefTransactionMarker
restriction (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
e)
    Equals GraphRefRelationalExpr
a GraphRefRelationalExpr
b ->
      forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Equals (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
a) (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
b)
    NotEquals GraphRefRelationalExpr
a GraphRefRelationalExpr
b ->
      forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
NotEquals (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
a) (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
b)
    Extend GraphRefExtendTupleExpr
tupExprs GraphRefRelationalExpr
e ->
      forall a.
ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Extend GraphRefExtendTupleExpr
tupExprs (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
e)
    With GraphRefWithNameAssocs
withs GraphRefRelationalExpr
e ->
      forall a.
WithNamesAssocsBase a
-> RelationalExprBase a -> RelationalExprBase a
With GraphRefWithNameAssocs
withs (GraphRefRelationalExpr -> GraphRefRelationalExpr
hint GraphRefRelationalExpr
e)
    GraphRefRelationalExpr
_ -> GraphRefRelationalExpr
expr
  where
    targetAttrExprs :: [AttributeExprBase a]
targetAttrExprs = forall a b. (a -> b) -> [a] -> [b]
map forall a. Attribute -> AttributeExprBase a
NakedAttributeExpr (Attributes -> [Attribute]
A.toList Attributes
targetAttrs)
    hint :: GraphRefRelationalExpr -> GraphRefRelationalExpr
hint = Attributes -> GraphRefRelationalExpr -> GraphRefRelationalExpr
addTargetTypeHints Attributes
targetAttrs

-- | Ensure that the notification contains valid, type-checkable relational expressions. These relational expressions therefore become registered queries: queries which must remain valid.
validateNotification :: Notification -> DatabaseContext -> TransactionGraph -> Either RelationalError Notification
validateNotification :: Notification
-> DatabaseContext
-> TransactionGraph
-> Either RelationalError Notification
validateNotification Notification
notif DatabaseContext
context TransactionGraph
graph = do
  let reEnv :: RelationalExprEnv
reEnv = DatabaseContext -> TransactionGraph -> RelationalExprEnv
mkRelationalExprEnv DatabaseContext
context TransactionGraph
graph
  forall a.
RelationalExprEnv -> RelationalExprM a -> Either RelationalError a
runRelationalExprM RelationalExprEnv
reEnv forall a b. (a -> b) -> a -> b
$ do
    Relation
_ <- RelationalExpr -> RelationalExprM Relation
typeForRelationalExpr (Notification -> RelationalExpr
changeExpr Notification
notif)
    Relation
_ <- RelationalExpr -> RelationalExprM Relation
typeForRelationalExpr (Notification -> RelationalExpr
reportOldExpr Notification
notif)
    Relation
_ <- RelationalExpr -> RelationalExprM Relation
typeForRelationalExpr (Notification -> RelationalExpr
reportNewExpr Notification
notif)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Notification
notif