{-# LANGUAGE DeriveGeneric, DeriveAnyClass, LambdaCase #-}
module ProjectM36.IsomorphicSchema where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.MiscUtils
import ProjectM36.Relation
import ProjectM36.NormalizeExpr
import ProjectM36.RelationalExpression
import qualified ProjectM36.AttributeNames as AN
import Control.Monad
import GHC.Generics
import Data.Binary
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.List as L
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif
data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |
RemoveSubschema SchemaName
deriving (Generic, Binary, Show)
isomorphs :: Schema -> SchemaIsomorphs
isomorphs (Schema i) = i
validateSchema :: Schema -> DatabaseContext -> Maybe SchemaError
validateSchema potentialSchema baseContext | not (S.null rvDiff) = Just (RelVarReferencesMissing rvDiff)
| not (null outDupes) = Just (RelVarOutReferencedMoreThanOnce (head outDupes))
| not (null inDupes) = Just (RelVarInReferencedMoreThanOnce (head inDupes))
| otherwise = Nothing
where
outDupes = duplicateNames (namesList isomorphOutRelVarNames)
inDupes = duplicateNames (namesList isomorphInRelVarNames)
duplicateNames = dupes . L.sort
namesList isoFunc = concatMap isoFunc (isomorphs potentialSchema)
expectedRelVars = M.keysSet (relationVariables baseContext)
schemaRelVars = isomorphsOutRelVarNames (isomorphs potentialSchema)
rvDiff = S.difference expectedRelVars schemaRelVars
invert :: SchemaIsomorph -> SchemaIsomorph
invert (IsoRename rvIn rvOut) = IsoRename rvOut rvIn
invert (IsoRestrict rvIn predi (rvAOut, rvBOut)) = IsoUnion (rvAOut, rvBOut) predi rvIn
invert (IsoUnion (rvAIn, rvBIn) predi rvOut) = IsoRestrict rvOut predi (rvAIn, rvBIn)
isomorphInRelVarNames :: SchemaIsomorph -> [RelVarName]
isomorphInRelVarNames (IsoRestrict rv _ _) = [rv]
isomorphInRelVarNames (IsoUnion (rvA, rvB) _ _) = [rvA, rvB]
isomorphInRelVarNames (IsoRename rv _) = [rv]
isomorphsInRelVarNames :: SchemaIsomorphs -> S.Set RelVarName
isomorphsInRelVarNames morphs = S.fromList (foldr rvnames [] morphs)
where
rvnames morph acc = acc ++ isomorphInRelVarNames morph
isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName]
isomorphOutRelVarNames (IsoRestrict _ _ (rvA, rvB)) = [rvA, rvB]
isomorphOutRelVarNames (IsoUnion _ _ rv) = [rv]
isomorphOutRelVarNames (IsoRename _ rv) = [rv]
isomorphsOutRelVarNames :: SchemaIsomorphs -> S.Set RelVarName
isomorphsOutRelVarNames morphs = S.fromList (foldr rvnames [] morphs)
where
rvnames morph acc = acc ++ isomorphOutRelVarNames morph
validateRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError ()
validateRelationalExprInSchema schema relExprIn = relExprMogrify (\case
RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)
ex -> Right ex) relExprIn >> pure ()
where
validRelVarNames = isomorphsInRelVarNames (isomorphs schema)
processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr
processRelationalExprInSchema schema relExprIn = do
let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr
validateRelationalExprInSchema schema relExprIn
foldM processRelExpr relExprIn (isomorphs schema)
validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError ()
validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema) >> pure ()
processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
processDatabaseContextExprInSchema schema@(Schema morphs) dbExpr = do
let relExprMogrifier = processRelationalExprInSchema schema
_ <- validateDatabaseContextExprInSchema schema dbExpr
foldM (\ex morph -> databaseContextExprMorph morph relExprMogrifier ex) dbExpr morphs
processDatabaseContextExprSchemaUpdate :: Schema -> DatabaseContextExpr -> Schema
processDatabaseContextExprSchemaUpdate schema@(Schema morphs) expr = case expr of
Define rv _ | S.notMember rv validSchemaName -> passthru rv
Assign rv _ | S.notMember rv validSchemaName -> passthru rv
Undefine rv | S.member rv validSchemaName -> Schema (filter (elem rv . isomorphInRelVarNames) morphs)
MultipleExpr exprs -> foldr (flip processDatabaseContextExprSchemaUpdate) schema exprs
_ -> schema
where
validSchemaName = isomorphsInRelVarNames morphs
passthru rvname = Schema (morphs ++ [IsoRename rvname rvname])
processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas
processDatabaseContextExprSchemasUpdate subschemas expr = M.map (`processDatabaseContextExprSchemaUpdate` expr) subschemas
relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)
relExprMorph (IsoRestrict relIn _ (relOutTrue, relOutFalse)) = \case
RelationVariable rv () | rv == relIn -> Right (Union (RelationVariable relOutTrue ()) (RelationVariable relOutFalse ()))
orig -> Right orig
relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \case
RelationVariable rv () | rv == relInT -> Right (Restrict predi (RelationVariable relTarget ()))
RelationVariable rv () | rv == relInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget ()))
orig -> Right orig
relExprMorph (IsoRename relIn relOut) = \case
RelationVariable rv () | rv == relIn -> Right (RelationVariable relOut ())
orig -> Right orig
relExprMogrify :: (RelationalExpr -> Either RelationalError RelationalExpr) -> RelationalExpr -> Either RelationalError RelationalExpr
relExprMogrify func (Project attrs expr) = func expr >>= \ex -> func (Project attrs ex)
relExprMogrify func (Union exprA exprB) = do
exA <- func exprA
exB <- func exprB
func (Union exA exB)
relExprMogrify func (Join exprA exprB) = do
exA <- func exprA
exB <- func exprB
func (Join exA exB)
relExprMogrify func (Rename n1 n2 expr) = func expr >>= \ex -> func (Rename n1 n2 ex)
relExprMogrify func (Difference exprA exprB) = do
exA <- func exprA
exB <- func exprB
func (Difference exA exB)
relExprMogrify func (Group ns n expr) = func expr >>= \ex -> func (Group ns n ex)
relExprMogrify func (Ungroup n expr) = func expr >>= \ex -> func (Ungroup n ex)
relExprMogrify func (Restrict predi expr) = func expr >>= \ex -> func (Restrict predi ex)
relExprMogrify func (Equals exprA exprB) = do
exA <- func exprA
exB <- func exprB
func (Equals exA exB)
relExprMogrify func (NotEquals exprA exprB) = do
exA <- func exprA
exB <- func exprB
func (NotEquals exA exB)
relExprMogrify func (Extend ext expr) = func expr >>= \ex -> func (Extend ext ex)
relExprMogrify func other = func other
databaseContextExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr) -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
databaseContextExprMorph iso@(IsoRestrict rvIn filt (rvTrue, rvFalse)) relExprFunc expr = case expr of
Assign rv relExpr | rv == rvIn -> do
ex <- relExprFunc relExpr
let trueExpr n = Assign n (Restrict filt ex)
falseExpr n = Assign n (Restrict (NotPredicate filt) ex)
pure $ MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]
Insert rv relExpr | rv == rvIn -> do
ex <- relExprFunc relExpr
let trueExpr n = Insert n (Restrict filt ex)
falseExpr n = Insert n (Restrict (NotPredicate filt) ex)
pure $ MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]
Update rv attrMap predi | rv == rvIn -> do
let trueExpr n = Update n attrMap (AndPredicate predi filt)
falseExpr n = Update n attrMap (AndPredicate predi (NotPredicate filt))
pure (MultipleExpr [trueExpr rvTrue, falseExpr rvFalse])
MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs
orig -> pure orig
databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) relExprFunc expr = case expr of
Assign rv relExpr | rv == rvTrue -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut filt,
Insert rvOut (Restrict filt ex)]
Assign rv relExpr | rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt),
Insert rvOut (Restrict (NotPredicate filt) ex)]
Insert rv relExpr | rv == rvTrue || rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ Insert rvOut ex
Delete rv delPred | rv == rvTrue -> pure $ Delete rvOut (AndPredicate delPred filt)
Delete rv delPred | rv == rvFalse -> pure $ Delete rvOut (AndPredicate delPred (NotPredicate filt))
Update rv attrMap predi | rv == rvTrue -> pure $ Update rvOut attrMap (AndPredicate predi filt)
Update rv attrMap predi | rv == rvFalse -> pure $ Update rvOut attrMap (AndPredicate (NotPredicate filt) predi)
MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs
orig -> pure orig
databaseContextExprMorph iso@(IsoRename relIn relOut) relExprFunc expr = case expr of
Assign rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure (Assign relOut ex)
Insert rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure $ Insert relOut ex
Delete rv delPred | rv == relIn -> pure $ Delete relOut delPred
Update rv attrMap predi | rv == relIn -> pure $ Update relOut attrMap predi
MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs
orig -> pure orig
applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> Either RelationalError RelationalExpr
applyRelationalExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs
inclusionDependencyInSchema :: Schema -> InclusionDependency -> Either RelationalError InclusionDependency
inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do
let schemaRelVars = isomorphsInRelVarNames (isomorphs schema)
rvAssoc <- mapM (\rvIn -> do
rvOut <- processRelationalExprInSchema schema (RelationVariable rvIn ())
pure (rvOut, RelationVariable rvIn ())
)
(S.toList schemaRelVars)
let replacer exprOrig = foldM (\expr (find, replace) -> if expr == find then
pure replace
else
pure expr) exprOrig rvAssoc
rexprA' <- relExprMogrify replacer rexprA
rexprB' <- relExprMogrify replacer rexprB
pure (InclusionDependency rexprA' rexprB')
inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies
inclusionDependenciesInSchema schema incDeps = M.fromList <$> mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps)
relationVariablesInSchema :: Schema -> Either RelationalError RelationVariables
relationVariablesInSchema schema@(Schema morphs) = foldM transform M.empty morphs
where
transform newRvMap morph = do
let rvNames = isomorphInRelVarNames morph
rvAssocs <- mapM (\rv -> do
expr' <- processRelationalExprInSchema schema (RelationVariable rv ())
let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr')
pure (rv, gfExpr)) rvNames
pure (M.union newRvMap (M.fromList rvAssocs))
applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables
applyRelationVariablesSchemaIsomorphs = undefined
applySchemaIsomorphsToDatabaseContext :: SchemaIsomorphs -> DatabaseContext -> Either RelationalError DatabaseContext
applySchemaIsomorphsToDatabaseContext morphs context = do
relvars <- applyRelationVariablesSchemaIsomorphs morphs (relationVariables context)
pure (context {
relationVariables = relvars
})
createIncDepsForIsomorph :: SchemaName -> SchemaIsomorph -> InclusionDependencies
createIncDepsForIsomorph sname (IsoRestrict origRv predi (rvTrue, rvFalse)) = let
newIncDep predicate rv = InclusionDependency (Project AN.empty (Restrict predicate (RelationVariable rv ()))) (ExistingRelation relationTrue)
incDepName b = "schema" <> "_" <> sname <> "_" <> b in
M.fromList [(incDepName (origRv <> "_true"), newIncDep predi rvTrue),
(incDepName (origRv <> "_false"), newIncDep (NotPredicate predi) rvFalse)]
createIncDepsForIsomorph _ _ = M.empty
evalSchemaExpr :: SchemaExpr -> DatabaseContext -> TransactionId -> TransactionGraph -> Subschemas -> Either RelationalError (Subschemas, DatabaseContext)
evalSchemaExpr (AddSubschema sname morphs) context transId graph sschemas =
if M.member sname sschemas then
Left (SubschemaNameInUseError sname)
else
case validateSchema (Schema morphs) context of
Just err -> Left (SchemaCreationError err)
Nothing -> do
let newSchemas = M.insert sname newSchema sschemas
newSchema = Schema morphs
moreIncDeps = foldr (\morph acc -> M.union acc (createIncDepsForIsomorph sname morph)) M.empty morphs
incDepExprs = MultipleExpr (map (uncurry AddInclusionDependency) (M.toList moreIncDeps))
dbenv = mkDatabaseContextEvalEnv transId graph
dbstate <- runDatabaseContextEvalMonad context dbenv (evalGraphRefDatabaseContextExpr incDepExprs)
pure (newSchemas, dbc_context dbstate)
evalSchemaExpr (RemoveSubschema sname) context _ _ sschemas = if M.member sname sschemas then
pure (M.delete sname sschemas, context)
else
Left (SubschemaNameNotInUseError sname)