module ProjectM36.NormalizeExpr where
import ProjectM36.Base
import Control.Monad.Trans.Reader as R
import qualified Data.Map as M
type ProcessExprM a = Reader GraphRefTransactionMarker a
type CurrentTransactionId = TransactionId
runProcessExprM :: GraphRefTransactionMarker -> ProcessExprM a -> a
runProcessExprM mtid m = runReader m mtid
askMarker :: ProcessExprM GraphRefTransactionMarker
askMarker = R.ask
processRelationalExpr :: RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do
mAttrs' <- case mAttrs of
Nothing -> pure Nothing
Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''
MakeRelationFromExprs mAttrs' <$> processTupleExprs tupleExprs
processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)
processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)
processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> askMarker
processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr
processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB
processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB
processRelationalExpr (Rename attrA attrB expr) =
Rename attrA attrB <$> processRelationalExpr expr
processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB
processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr
processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr
processRelationalExpr (Restrict pred' expr) = Restrict <$> processRestrictionPredicateExpr pred' <*> processRelationalExpr expr
processRelationalExpr (Equals exprA exprB) =
Equals <$> processRelationalExpr exprA <*> processRelationalExpr exprB
processRelationalExpr (NotEquals exprA exprB) =
NotEquals <$> processRelationalExpr exprA <*> processRelationalExpr exprB
processRelationalExpr (Extend extendExpr expr) =
Extend <$> processExtendTupleExpr extendExpr <*> processRelationalExpr expr
processRelationalExpr (With macros expr) =
With <$> mapM (\(wnexpr, macroExpr) -> (,) <$> processWithNameExpr wnexpr <*> processRelationalExpr macroExpr) macros <*> processRelationalExpr expr
processWithNameExpr :: WithNameExpr -> ProcessExprM GraphRefWithNameExpr
processWithNameExpr (WithNameExpr rvname ()) =
WithNameExpr rvname <$> askMarker
processAttributeNames :: AttributeNames -> ProcessExprM GraphRefAttributeNames
processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet
processAttributeNames (InvertedAttributeNames attrNameSet) =
pure $ InvertedAttributeNames attrNameSet
processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr
processDatabaseContextExpr :: DatabaseContextExpr -> ProcessExprM GraphRefDatabaseContextExpr
processDatabaseContextExpr expr =
case expr of
NoOperation -> pure NoOperation
Define nam attrExprs -> Define nam <$> mapM processAttributeExpr attrExprs
Undefine nam -> pure (Undefine nam)
Assign nam rexpr -> Assign nam <$> processRelationalExpr rexpr
Insert nam rexpr -> Insert nam <$> processRelationalExpr rexpr
Delete nam pred' -> Delete nam <$> processRestrictionPredicateExpr pred'
Update nam attrMap pred' -> Update nam attrMap <$> processRestrictionPredicateExpr pred'
AddInclusionDependency nam dep -> pure (AddInclusionDependency nam dep)
RemoveInclusionDependency nam -> pure (RemoveInclusionDependency nam)
AddNotification nam exprA exprB exprC -> pure (AddNotification nam exprA exprB exprC)
RemoveNotification nam -> pure (RemoveNotification nam)
AddTypeConstructor tyDef consDefs -> pure (AddTypeConstructor tyDef consDefs)
RemoveTypeConstructor tyName -> pure (RemoveTypeConstructor tyName)
RemoveAtomFunction aFuncName -> pure (RemoveAtomFunction aFuncName)
RemoveDatabaseContextFunction funcName -> pure (RemoveDatabaseContextFunction funcName)
ExecuteDatabaseContextFunction funcName atomExprs -> ExecuteDatabaseContextFunction funcName <$> mapM processAtomExpr atomExprs
MultipleExpr exprs -> MultipleExpr <$> mapM processDatabaseContextExpr exprs
processDatabaseContextIOExpr :: DatabaseContextIOExpr -> ProcessExprM GraphRefDatabaseContextIOExpr
processDatabaseContextIOExpr (AddAtomFunction f tcs sc) =
pure (AddAtomFunction f tcs sc)
processDatabaseContextIOExpr (LoadAtomFunctions mod' fun file) =
pure (LoadAtomFunctions mod' fun file)
processDatabaseContextIOExpr (AddDatabaseContextFunction mod' fun path) =
pure (AddDatabaseContextFunction mod' fun path)
processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod' fun path) =
pure (LoadDatabaseContextFunctions mod' fun path)
processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =
CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range
processRestrictionPredicateExpr :: RestrictionPredicateExpr -> ProcessExprM GraphRefRestrictionPredicateExpr
processRestrictionPredicateExpr TruePredicate = pure TruePredicate
processRestrictionPredicateExpr (AndPredicate a b) = AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
processRestrictionPredicateExpr (NotPredicate a) = NotPredicate <$> processRestrictionPredicateExpr a
processRestrictionPredicateExpr (RelationalExprPredicate expr) =
RelationalExprPredicate <$> processRelationalExpr expr
processRestrictionPredicateExpr (AtomExprPredicate expr) =
AtomExprPredicate <$> processAtomExpr expr
processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) =
AttributeEqualityPredicate nam <$> processAtomExpr expr
processExtendTupleExpr :: ExtendTupleExpr -> ProcessExprM GraphRefExtendTupleExpr
processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =
AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr
processAtomExpr :: AtomExpr -> ProcessExprM GraphRefAtomExpr
processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam
processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
processAtomExpr (FunctionAtomExpr fName atomExprs ()) =
FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> askMarker
processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr
processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> askMarker
processTupleExprs :: TupleExprs -> ProcessExprM GraphRefTupleExprs
processTupleExprs (TupleExprs () tupleExprs) = do
marker <- askMarker
TupleExprs marker <$> mapM processTupleExpr tupleExprs
processTupleExpr :: TupleExpr -> ProcessExprM GraphRefTupleExpr
processTupleExpr (TupleExpr tMap) =
TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)
processAttributeExpr :: AttributeExpr -> ProcessExprM GraphRefAttributeExpr
processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) =
AttributeAndTypeNameExpr nam tCons <$> askMarker
processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr