d0ed854 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

inclusion dependency schema conversion working

d0ed854AgentM10 years ago

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

compare with master

unifiedsplit

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

23 SetCurrentSchema <$> identifier

25schemaExprP :: Parser SchemaExpr

26−schemaExprP = addSubschemaIsoMorphP <|>

26+schemaExprP = addSubschemaP <|>

27− addSubschemaP

27+ removeSubschemaP

28−

28+

29addSubschemaP :: Parser SchemaExpr

30addSubschemaP = do

31 reserved ":addsubschema"

32− AddSubschema <$> identifier

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

33−

34−addSubschemaIsoMorphP :: Parser SchemaExpr

35−addSubschemaIsoMorphP = do

36− reserved ":addsubschemaisomorph"

37− AddSubschemaIsomorph <$> identifier <*> schemaIsomorphP

39schemaIsomorphP :: Parser SchemaIsomorph

34schemaIsomorphP :: 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

42isoRestrictP :: Parser SchemaIsomorph

43isoRestrictP = do

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

57 reserved "isounion"

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

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+

60isoUnionInRelVarsP :: Parser (RelVarName, RelVarName)

71isoUnionInRelVarsP :: Parser (RelVarName, RelVarName)

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

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

src/lib/ProjectM36/Base.hs+1

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

273 deriving (Generic, Binary)

274

275data 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 |

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

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

277 -- IsoTypeConstructor in morphAttrExpr

278 -- IsoTypeConstructor in morphAttrExpr

278 deriving (Generic, Binary)

279 deriving (Generic, Binary)

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

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

407 eSession <- sessionAndSchema sessionId sessions

408 case eSession of

409 Left err -> pure $ Left err

410+ Right (session, schema) -> do

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

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

412+ Schema.processRelationalExprInSchema schema expr

413+ else

414+ Right expr

415+ case expr' of

411 Left err -> pure (Left err)

416 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

413 Left err -> pure (Left err)

418 Left err -> pure (Left err)

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

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

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

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

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

535 eSession <- sessionAndSchema sessionId sessions

540 eSession <- sessionAndSchema sessionId sessions

536 case eSession of

541 case eSession of

537 Left err -> pure (Just err)

542 Left err -> pure (Just err)

538− Right (session, schema) -> do

543+ Right (session, _) -> do

539 let subschemas' = subschemas session

544 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

545 Left err -> pure (Just err)

546 Left err -> pure (Just err)

546 Right newSubschemas -> do

547 Right newSubschemas -> do

547 --hm- maybe we should start using lenses

548 --hm- maybe we should start using lenses

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

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

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

595

596

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

597-- | 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)

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

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

599 atomically $ do

600 atomically $ do

600 eSession <- sessionAndSchema sessionId sessions

601 eSession <- sessionAndSchema sessionId sessions

601 case eSession of

602 case eSession of

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

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

604+ Right (session, schema) -> do

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

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))

604

610

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

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

606

612

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

638 case eSession of

644 case eSession of

639 Left err -> pure (Left err)

645 Left err -> pure (Left err)

640 Right (session, schema) -> do

646 Right (session, schema) -> do

647+ let context = Sess.concreteDatabaseContext session

648+ if Sess.schemaName session == defaultSchemaName then

649+ pure $ R.relationVariablesAsRelation (relationVariables context)

650+ else

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

651+ case Schema.relationVariablesInSchema schema context of

642− Left err -> pure (Left err)

652+ Left err -> pure (Left err)

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

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

644

654

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

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

646

656

src/lib/ProjectM36/Error.hs+7

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

77 | SubschemaNameInUseError SchemaName

78 | SubschemaNameNotInUseError SchemaName

80+ | SchemaCreationError SchemaError

81 | MultipleErrors [RelationalError]

82 | MultipleErrors [RelationalError]

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

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

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

112 ScriptCompilationDisabledError |

113 ScriptCompilationDisabledError |

113 OtherScriptCompilationError String

114 OtherScriptCompilationError String

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

115 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+

115

122

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

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

2module ProjectM36.IsomorphicSchema where

3import ProjectM36.Base

4import ProjectM36.Error

5+import ProjectM36.MiscUtils

5import ProjectM36.RelationalExpression

6import ProjectM36.RelationalExpression

6import Control.Monad

7import Control.Monad

7import Control.Monad.State

8import Control.Monad.State

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

9import Data.Binary

10import Data.Binary

10import qualified Data.Map as M

11import qualified Data.Map as M

11import qualified Data.Set as S

12import qualified Data.Set as S

13+import qualified Data.List as L

12--import Debug.Trace

14--import Debug.Trace

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

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

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

21-- 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

23-- 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

23−data SchemaExpr = AddSubschema SchemaName |

25+data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs|

24− AddSubschemaIsomorph SchemaName SchemaIsomorph |

25 RemoveSubschema SchemaName

26 RemoveSubschema SchemaName

26 deriving (Generic, Binary)

27 deriving (Generic, Binary)

29+

28isomorphs :: Schema -> SchemaIsomorphs

30isomorphs :: Schema -> SchemaIsomorphs

29isomorphs (Schema i) = i

31isomorphs (Schema i) = i

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+

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

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

32invert :: SchemaIsomorph -> SchemaIsomorph

51invert :: SchemaIsomorph -> SchemaIsomorph

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

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

34−-}

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

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

36isomorphInRelVarNames :: SchemaIsomorph -> [RelVarName]

56isomorphInRelVarNames :: SchemaIsomorph -> [RelVarName]

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

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

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

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

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

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

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

41isomorphsInRelVarNames :: SchemaIsomorphs -> S.Set RelVarName

62isomorphsInRelVarNames :: SchemaIsomorphs -> S.Set RelVarName

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

46isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName]

67isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName]

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

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

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

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

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

50isomorphsOutRelVarNames :: SchemaIsomorphs -> S.Set RelVarName

72isomorphsOutRelVarNames :: SchemaIsomorphs -> S.Set RelVarName

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

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

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

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

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

56processRelationalExprInSchema (Schema morphs) relExprIn = do

78processRelationalExprInSchema (Schema morphs) relExprIn = do

57− let validRelVarNames = isomorphsInRelVarNames morphs

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

79 --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

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

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

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

61− ex -> relExprMorph morph ex) rexpr

85+ ex -> Right ex) relExprIn

62−

86+

63 foldM processRelExpr relExprIn morphs

87 foldM processRelExpr relExprIn morphs

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

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

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

122

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

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

100 orig -> Right orig

124 orig -> Right orig

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

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

127+ orig -> Right orig

101

128

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

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

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

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

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

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

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

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

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

170 orig -> pure orig

197 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

171

204

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

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

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

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

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

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

175

208

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

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

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

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

178−

211+-- x = x1 union x2

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

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

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

213+inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do

181−applyInclusionDependenciesSchemaIsoMorphs _ _ = undefined

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')

182

228

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+

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

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

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

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

185 where

234 where

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

206

255

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

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

208applySchemaIsomorphsToDatabaseContext morphs context = do

257applySchemaIsomorphsToDatabaseContext morphs context = do

209− incdeps <- applyInclusionDependenciesSchemaIsoMorphs morphs (inclusionDependencies context)

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

210 relvars <- applyRelationVariablesSchemaIsomorphs morphs (relationVariables context)

259 relvars <- applyRelationVariablesSchemaIsomorphs morphs (relationVariables context)

211− pure (context { inclusionDependencies = incdeps,

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

212 relationVariables = relvars

261 relationVariables = relvars

213 --atomFunctions = atomfuncs,

262 --atomFunctions = atomfuncs,

214 --notifications = notifs,

263 --notifications = notifs,

215 --typeConstructorMapping = tconsmapping

264 --typeConstructorMapping = tconsmapping

216 })

265 })

217

266

267+{-

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

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

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

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

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

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

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

223 where

273 where

224 morphRvNames = S.fromList (isomorphOutRelVarNames morph)

274 morphRvNames = S.fromList (isomorphOutRelVarNames morph)

225 invalidRvNames = S.difference morphRvNames underlyingRvNames

275 invalidRvNames = S.difference morphRvNames underlyingRvNames

276+-}

226

277

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

278-- 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

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

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

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

230 Left (SubschemaNameInUseError sname)

281 Left (SubschemaNameInUseError sname)

231− else

282+ else case valid of

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

283+ Just err -> Left (SchemaCreationError err)

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

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

234− Nothing -> Left (SubschemaNameNotInUseError sname)

285+ where

235− Just (Schema oldMorphs) -> do

286+ newSchema = Schema morphs

236− morph' <- validate morph underlyingRvNames

287+ valid = validateSchema newSchema context

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

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

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

239 pure (M.delete sname sschemas)

289 pure (M.delete sname sschemas)

240 else

290 else