d0ed854 · project-m36 · git.iko.soy

git.iko.soy/project-m36

inclusion dependency schema conversion working

isomorph rename and passthrough

commitd0ed854b2804efb54a7668510e9e1c93d289ebf8 authorAgentM <agentm@themactionfaction.com> dateSun 6 Nov 2016, 12:29 (10 years ago) parentca59541

5 files changed+130−51

compare with master

unifiedsplit

src/bin/TutorialD/Interpreter/SchemaOperator.hs+21−10 src/lib/ProjectM36/Base.hs+1 src/lib/ProjectM36/Client.hs+23−13 src/lib/ProjectM36/Error.hs+7 src/lib/ProjectM36/IsomorphicSchema.hs+78−28

src/bin/TutorialD/Interpreter/SchemaOperator.hs+21−10

@@ -23,21 +23,21 @@ setCurrentSchemaP = do

2323 SetCurrentSchema <$> identifier

2424

2525schemaExprP :: Parser SchemaExpr

26−schemaExprP = addSubschemaIsoMorphP <|>

27− addSubschemaP

28−

26+schemaExprP = addSubschemaP <|>

27+ removeSubschemaP

28+

2929addSubschemaP :: Parser SchemaExpr

3030addSubschemaP = do

3131 reserved ":addsubschema"

32− AddSubschema <$> identifier

33−

34−addSubschemaIsoMorphP :: Parser SchemaExpr

35−addSubschemaIsoMorphP = do

36− reserved ":addsubschemaisomorph"

37− AddSubschemaIsomorph <$> identifier <*> schemaIsomorphP

32+ AddSubschema <$> identifier <*> parens (sepBy schemaIsomorphP comma)

3833

3934schemaIsomorphP :: Parser SchemaIsomorph

40−schemaIsomorphP = isoRestrictP <|> isoUnionP

35+schemaIsomorphP = isoRestrictP <|> isoUnionP <|> isoRenameP <|> isoPassthrough

36+

37+removeSubschemaP :: Parser SchemaExpr

38+removeSubschemaP = do

39+ reserved ":removesubschema"

40+ RemoveSubschema <$> identifier

4141

4242isoRestrictP :: Parser SchemaIsomorph

4343isoRestrictP = do

@@ -57,6 +57,17 @@ isoUnionP = do

5757 reserved "isounion"

5858 IsoUnion <$> isoUnionInRelVarsP <*> restrictionPredicateP <*> qrelVarP

5959

60+isoRenameP :: Parser SchemaIsomorph

61+isoRenameP = do

62+ reserved "isorename"

63+ IsoRename <$> qrelVarP <*> qrelVarP

64+

65+isoPassthrough :: Parser SchemaIsomorph

66+isoPassthrough = do

67+ reserved "isopassthrough"

68+ rv <- qrelVarP

69+ pure (IsoRename rv rv)

70+

6071isoUnionInRelVarsP :: Parser (RelVarName, RelVarName)

6172isoUnionInRelVarsP = (,) <$> qrelVarP <*> qrelVarP

6273

src/lib/ProjectM36/Base.hs+1

@@ -273,6 +273,7 @@ data Schema = Schema SchemaIsomorphs

273273 deriving (Generic, Binary)

274274

275275data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName, RelVarName) | --maps one relvar into two relvars (true, false), if the false name is Nothing, no relvar in schemaB is created. This is useful for renaming relation variables between schemas or hiding relvars altogether.

276+ IsoRename RelVarName RelVarName |

276277 IsoUnion (RelVarName, RelVarName) RestrictionPredicateExpr RelVarName --maps two relvars to one relvar

277278 -- IsoTypeConstructor in morphAttrExpr

278279 deriving (Generic, Binary)

src/lib/ProjectM36/Client.hs+23−13

@@ -407,9 +407,14 @@ executeRelationalExpr sessionId (InProcessConnection _ _ sessions _ _) expr = ex

407407 eSession <- sessionAndSchema sessionId sessions

408408 case eSession of

409409 Left err -> pure $ Left err

410− Right (session, schema) -> case Schema.processRelationalExprInSchema schema expr of

410+ Right (session, schema) -> do

411+ let expr' = if schemaName session /= defaultSchemaName then

412+ Schema.processRelationalExprInSchema schema expr

413+ else

414+ Right expr

415+ case expr' of

411416 Left err -> pure (Left err)

412− Right expr' -> case evalState (RE.evalRelationalExpr expr') (Sess.concreteDatabaseContext session) of

417+ Right expr'' -> case evalState (RE.evalRelationalExpr expr'') (Sess.concreteDatabaseContext session) of

413418 Left err -> pure (Left err)

414419 Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here

415420executeRelationalExpr sessionId conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)

@@ -535,13 +540,9 @@ executeSchemaExpr sessionId (InProcessConnection _ _ sessions _ _) schemaExpr =

535540 eSession <- sessionAndSchema sessionId sessions

536541 case eSession of

537542 Left err -> pure (Just err)

538− Right (session, schema) -> do

543+ Right (session, _) -> do

539544 let subschemas' = subschemas session

540− underlyingRelVarNames = if schemaName session == defaultSchemaName then

541− M.keysSet (relationVariables (Sess.concreteDatabaseContext session))

542− else

543− Schema.isomorphsInRelVarNames (Schema.isomorphs schema)

544− case Schema.evalSchemaExpr schemaExpr underlyingRelVarNames subschemas' of

545+ case Schema.evalSchemaExpr schemaExpr (Sess.concreteDatabaseContext session) subschemas' of

545546 Left err -> pure (Just err)

546547 Right newSubschemas -> do

547548 --hm- maybe we should start using lenses

@@ -594,13 +595,18 @@ typeForRelationalExprSTM sessionId (InProcessConnection _ _ sessions _ _) relExp

594595typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection"

595596

596597-- | Return a 'Map' of the database's constraints at the context of the session and connection.

597−inclusionDependencies :: SessionId -> Connection -> IO (Either RelationalError (M.Map IncDepName InclusionDependency))

598+inclusionDependencies :: SessionId -> Connection -> IO (Either RelationalError InclusionDependencies)

598599inclusionDependencies sessionId (InProcessConnection _ _ sessions _ _) = do

599600 atomically $ do

600601 eSession <- sessionAndSchema sessionId sessions

601602 case eSession of

602603 Left err -> pure $ Left err --TODO: schema application

603− Right (session, schema) -> pure $ Right (B.inclusionDependencies (Sess.concreteDatabaseContext session))

604+ Right (session, schema) -> do

605+ let context = Sess.concreteDatabaseContext session

606+ if schemaName session == defaultSchemaName then

607+ pure $ Right (B.inclusionDependencies context)

608+ else

609+ pure (Schema.inclusionDependenciesInSchema schema (B.inclusionDependencies context))

604610

605611inclusionDependencies sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveInclusionDependencies sessionId)

606612

@@ -638,9 +644,13 @@ relationVariablesAsRelation sessionId (InProcessConnection _ _ sessions _ _) = d

638644 case eSession of

639645 Left err -> pure (Left err)

640646 Right (session, schema) -> do

641− case Schema.relationVariablesInSchema schema (Sess.concreteDatabaseContext session) of

642− Left err -> pure (Left err)

643− Right relvars -> pure $ R.relationVariablesAsRelation relvars

647+ let context = Sess.concreteDatabaseContext session

648+ if Sess.schemaName session == defaultSchemaName then

649+ pure $ R.relationVariablesAsRelation (relationVariables context)

650+ else

651+ case Schema.relationVariablesInSchema schema context of

652+ Left err -> pure (Left err)

653+ Right relvars -> pure $ R.relationVariablesAsRelation relvars

644654

645655relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

646656

src/lib/ProjectM36/Error.hs+7

@@ -77,6 +77,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

7777 | SubschemaNameInUseError SchemaName

7878 | SubschemaNameNotInUseError SchemaName

7979

80+ | SchemaCreationError SchemaError

8081

8182 | MultipleErrors [RelationalError]

8283 deriving (Show,Eq,Generic,Binary,Typeable)

@@ -112,4 +113,10 @@ data AtomFunctionBodyCompilationError = TypeCheckCompilationError String String

112113 ScriptCompilationDisabledError |

113114 OtherScriptCompilationError String

114115 deriving (Show,Eq, Generic, Binary, Typeable, NFData)

116+

117+data SchemaError = RelVarReferencesMissing (S.Set RelVarName) |

118+ RelVarReferencedMoreThanOnce RelVarName

119+ deriving (Show, Eq, Generic, Binary, Typeable, NFData)

120+

121+

115122

src/lib/ProjectM36/IsomorphicSchema.hs+78−28

@@ -2,6 +2,7 @@

22module ProjectM36.IsomorphicSchema where

33import ProjectM36.Base

44import ProjectM36.Error

5+import ProjectM36.MiscUtils

56import ProjectM36.RelationalExpression

67import Control.Monad

78import Control.Monad.State

@@ -9,6 +10,7 @@ import GHC.Generics

910import Data.Binary

1011import qualified Data.Map as M

1112import qualified Data.Set as S

13+import qualified Data.List as L

1214--import Debug.Trace

1315-- isomorphic schemas offer bi-directional functors between two schemas

1416

@@ -20,22 +22,41 @@ import qualified Data.Set as S

2022

2123-- the isomorphic building blocks should not be arbitrarily combined; for example, combing restrict and union on the same target relvar does not make sense as that would create effects at a distance in the secondary schema

2224

23−data SchemaExpr = AddSubschema SchemaName |

24− AddSubschemaIsomorph SchemaName SchemaIsomorph |

25+data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs|

2526 RemoveSubschema SchemaName

2627 deriving (Generic, Binary)

2728

29+

2830isomorphs :: Schema -> SchemaIsomorphs

2931isomorphs (Schema i) = i

3032

31−{- -- useful for transforming a concrete context into a virtual schema and vice versa

33+-- | Return an error if the schema is not isomorphic to the base database context.

34+-- A schema is fully isomorphic iff all relvars in the base context are in the "out" relvars, but only once.

35+--TODO: add relvar must appear exactly once constraint

36+validateSchema :: Schema -> DatabaseContext -> Maybe SchemaError

37+validateSchema potentialSchema baseContext = if not (S.null rvDiff) then

38+ Just (RelVarReferencesMissing rvDiff)

39+ else if not (null duplicateNames) then

40+ Just (RelVarReferencedMoreThanOnce (head duplicateNames))

41+ else

42+ Nothing

43+ where

44+ duplicateNames = dupes (L.sort outRvNamesList)

45+ outRvNamesList = concat (map isomorphOutRelVarNames (isomorphs potentialSchema))

46+ expectedRelVars = M.keysSet (relationVariables baseContext)

47+ schemaRelVars = isomorphsOutRelVarNames (isomorphs potentialSchema)

48+ rvDiff = S.difference expectedRelVars schemaRelVars

49+

50+-- useful for transforming a concrete context into a virtual schema and vice versa

3251invert :: SchemaIsomorph -> SchemaIsomorph

33−invert (IsoRelVarName nameA nameB) = IsoRelVarName nameB nameA

34−-}

52+invert (IsoRename rvIn rvOut) = IsoRename rvOut rvIn

53+invert (IsoRestrict rvIn predi (rvAOut, rvBOut)) = IsoUnion (rvAOut, rvBOut) predi rvIn

54+invert (IsoUnion (rvAIn, rvBIn) predi rvOut) = IsoRestrict rvOut predi (rvAIn, rvBIn)

3555

3656isomorphInRelVarNames :: SchemaIsomorph -> [RelVarName]

3757isomorphInRelVarNames (IsoRestrict rv _ _) = [rv]

3858isomorphInRelVarNames (IsoUnion (rvA, rvB) _ _) = [rvA, rvB]

59+isomorphInRelVarNames (IsoRename rv _) = [rv]

3960

4061-- | Relation variables names represented in the virtual schema space. Useful for determining if a relvar name is valid in the schema.

4162isomorphsInRelVarNames :: SchemaIsomorphs -> S.Set RelVarName

@@ -45,7 +66,8 @@ isomorphsInRelVarNames morphs = S.fromList (foldr rvnames [] morphs)

4566

4667isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName]

4768isomorphOutRelVarNames (IsoRestrict _ _ (rvA, rvB)) = [rvA, rvB]

48−isomorphOutRelVarNames (IsoUnion _ _ rvA) = [rvA]

69+isomorphOutRelVarNames (IsoUnion _ _ rv) = [rv]

70+isomorphOutRelVarNames (IsoRename _ rv) = [rv]

4971

5072isomorphsOutRelVarNames :: SchemaIsomorphs -> S.Set RelVarName

5173isomorphsOutRelVarNames morphs = S.fromList (foldr rvnames [] morphs)

@@ -54,12 +76,14 @@ isomorphsOutRelVarNames morphs = S.fromList (foldr rvnames [] morphs)

5476

5577processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr

5678processRelationalExprInSchema (Schema morphs) relExprIn = do

57− let validRelVarNames = isomorphsInRelVarNames morphs

5879 --validate that all rvs are present in the virtual schema- this prevents relation variables being referenced in the underlying schema (falling through the transformation)

59− let processRelExpr rexpr morph = relExprMogrify (\expr -> case expr of

60− RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)

61− ex -> relExprMorph morph ex) rexpr

62−

80+ let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr

81+ -- validate all in relvar names so that the actual relvar names don't leak through as errors

82+ validRelVarNames = isomorphsInRelVarNames morphs

83+ _ <- relExprMogrify (\expr -> case expr of

84+ RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)

85+ ex -> Right ex) relExprIn

86+

6387 foldM processRelExpr relExprIn morphs

6488

6589processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr

@@ -98,6 +122,9 @@ relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \expr -> case expr of

98122

99123 RelationVariable rv () | rv == relInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget ()))

100124 orig -> Right orig

125+relExprMorph (IsoRename relIn relOut) = \expr -> case expr of

126+ RelationVariable rv () | rv == relIn -> Right (RelationVariable relOut ())

127+ orig -> Right orig

101128

102129relExprMogrify :: (RelationalExpr -> Either RelationalError RelationalExpr) -> RelationalExpr -> Either RelationalError RelationalExpr

103130relExprMogrify func (Project attrs expr) = func expr >>= \ex -> func (Project attrs ex)

@@ -168,18 +195,40 @@ databaseContextExprMorph (IsoUnion (rvTrue, rvFalse) filt rvOut) relExprFunc exp

168195 Update rv attrMap predi | rv == rvTrue -> pure $ Update rvOut attrMap (AndPredicate predi filt)

169196 Update rv attrMap predi | rv == rvFalse -> pure $ Update rvOut attrMap (AndPredicate (NotPredicate filt) predi)

170197 orig -> pure orig

198+databaseContextExprMorph (IsoRename relIn relOut) relExprFunc expr = case expr of

199+ Assign rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure (Assign relOut ex)

200+ Insert rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure $ Insert relOut ex

201+ Delete rv delPred | rv == relIn -> pure $ Delete relOut delPred

202+ Update rv attrMap predi | rv == relIn -> pure $ Update relOut attrMap predi

203+ orig -> pure orig

171204

172205-- | Apply the isomorphism transformations to the relational expression to convert the relational expression from operating on one schema to a disparate, isomorphic schema.

173206applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> Either RelationalError RelationalExpr

174207applyRelationalExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs

175208

176−inclusionDependenciesMorph :: SchemaIsomorph -> (InclusionDependency -> Either RelationalError InclusionDependency)

177−inclusionDependenciesMorph iso = \(InclusionDependency subExpr expr) -> InclusionDependency <$> relExprMorph iso subExpr <*> relExprMorph iso expr

178−

179−applyInclusionDependenciesSchemaIsoMorphs :: SchemaIsomorphs -> InclusionDependencies -> Either RelationalError InclusionDependencies

180−--add inc deps for restriction with some automatic name

181−applyInclusionDependenciesSchemaIsoMorphs _ _ = undefined

209+-- the morph must be applied in the opposite direction

210+--algorithm: create a relexpr for each relvar in the schema, then replace those rel exprs wherever they appear in the inc dep relexprs

211+-- x = x1 union x2

212+inclusionDependencyInSchema :: Schema -> InclusionDependency -> Either RelationalError InclusionDependency

213+inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do

214+ --collect all relvars which appear in the schema

215+ let schemaRelVars = isomorphsInRelVarNames (isomorphs schema)

216+ rvAssoc <- mapM (\rvIn -> do

217+ rvOut <- processRelationalExprInSchema schema (RelationVariable rvIn ())

218+ pure (rvOut, RelationVariable rvIn ())

219+ )

220+ (S.toList schemaRelVars)

221+ let replacer exprOrig = foldM (\expr (find, replace) -> if expr == find then

222+ pure replace

223+ else

224+ pure expr) exprOrig rvAssoc

225+ rexprA' <- relExprMogrify replacer rexprA

226+ rexprB' <- relExprMogrify replacer rexprB

227+ pure (InclusionDependency rexprA' rexprB')

182228

229+inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies

230+inclusionDependenciesInSchema schema incDeps = mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps) >>= pure . M.fromList

231+

183232relationVariablesInSchema :: Schema -> DatabaseContext -> Either RelationalError RelationVariables

184233relationVariablesInSchema schema@(Schema morphs) context = foldM transform M.empty morphs

185234 where

@@ -206,15 +255,16 @@ applyRelationVariablesSchemaIsomorphs = undefined

206255

207256applySchemaIsomorphsToDatabaseContext :: SchemaIsomorphs -> DatabaseContext -> Either RelationalError DatabaseContext

208257applySchemaIsomorphsToDatabaseContext morphs context = do

209− incdeps <- applyInclusionDependenciesSchemaIsoMorphs morphs (inclusionDependencies context)

258+-- incdeps <- inclusionDependen morphs (inclusionDependencies context)

210259 relvars <- applyRelationVariablesSchemaIsomorphs morphs (relationVariables context)

211− pure (context { inclusionDependencies = incdeps,

260+ pure (context { --inclusionDependencies = incdeps,

212261 relationVariables = relvars

213262 --atomFunctions = atomfuncs,

214263 --notifications = notifs,

215264 --typeConstructorMapping = tconsmapping

216265 })

217266

267+{-

218268validate :: SchemaIsomorph -> S.Set RelVarName -> Either RelationalError SchemaIsomorph

219269validate morph underlyingRvNames = if S.size invalidRvNames > 0 then

220270 Left (MultipleErrors (map RelVarNotDefinedError (S.toList invalidRvNames)))

@@ -223,18 +273,18 @@ validate morph underlyingRvNames = if S.size invalidRvNames > 0 then

223273 where

224274 morphRvNames = S.fromList (isomorphOutRelVarNames morph)

225275 invalidRvNames = S.difference morphRvNames underlyingRvNames

276+-}

226277

227278-- the second argument really should be a database context in the future so we can morph other context items

228−evalSchemaExpr :: SchemaExpr -> S.Set RelVarName -> Subschemas -> Either RelationalError Subschemas

229−evalSchemaExpr (AddSubschema sname) _ sschemas = if M.member sname sschemas then

279+evalSchemaExpr :: SchemaExpr -> DatabaseContext -> Subschemas -> Either RelationalError Subschemas

280+evalSchemaExpr (AddSubschema sname morphs) context sschemas = if M.member sname sschemas then

230281 Left (SubschemaNameInUseError sname)

231− else

232− pure (M.insert sname (Schema []) sschemas)

233−evalSchemaExpr (AddSubschemaIsomorph sname morph) underlyingRvNames sschemas = case M.lookup sname sschemas of

234− Nothing -> Left (SubschemaNameNotInUseError sname)

235− Just (Schema oldMorphs) -> do

236− morph' <- validate morph underlyingRvNames

237− pure (M.insert sname (Schema (oldMorphs ++ [morph'])) sschemas)

282+ else case valid of

283+ Just err -> Left (SchemaCreationError err)

284+ Nothing -> pure (M.insert sname newSchema sschemas)

285+ where

286+ newSchema = Schema morphs

287+ valid = validateSchema newSchema context

238288evalSchemaExpr (RemoveSubschema sname) _ sschemas = if M.member sname sschemas then

239289 pure (M.delete sname sschemas)

240290 else