-- | Functions to convert all types of expresions into their GraphRef- equivalents.
module ProjectM36.NormalizeExpr where
import ProjectM36.Base
import Control.Monad.Trans.Reader as R
import qualified Data.Map as M

--used to process/normalize exprs to their respective graph ref forms
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

-- convert a RelationalExpr into a GraphRefRelationalExpr using the current trans Id
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)
--requires current trans id and graph
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)

--convert AttributeExpr to GraphRefAttributeExpr
processAttributeExpr :: AttributeExpr -> ProcessExprM GraphRefAttributeExpr
processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) =
  AttributeAndTypeNameExpr nam tCons <$> askMarker
processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr