git.iko.soy/project-m36
on master help sign in
WIP isomorphic schema test
commit399a04ab418e36355e2b61aa32a80dd8f47283e5 authorAgentM <agentm@themactionfaction.com> dateTue 20 Sep 2016, 22:49 (10 years ago) parent7bca08f
4 files changed+87−20
compare with master
unifiedsplit
project-m36.cabal+11 src/lib/ProjectM36/Base.hs−13 src/lib/ProjectM36/IsomorphicSchema.hs+22−7 test/IsomorphicSchema.hs+54
project-m36.cabal+11
@@ -93,6 +93,7 @@ Library
9393 ProjectM36.Relation.Show.CSV,
9494 ProjectM36.Relation.Show.Gnuplot,
9595 ProjectM36.Relation.Parse.CSV,
96+ ProjectM36.IsomorphicSchema,
9697 ProjectM36.Client,
9798 ProjectM36.Persist,
9899 ProjectM36.AtomType,
@@ -422,4 +423,14 @@ Test-Suite test-websocket-server
422423 Default-Extensions: OverloadedStrings
423424 GHC-Options: -Wall
424425 Hs-Source-Dirs: ./src/bin, .
426+ CPP-Options: -DPROJECTM36_VERSION="v0.1"
427+
428+Test-Suite test-isomorphic-schemas
429+ Default-Language: Haskell2010
430+ type: exitcode-stdio-1.0
431+ main-is: test/IsomorphicSchema.hs
432+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1
433+ Default-Extensions: OverloadedStrings
434+ GHC-Options: -Wall
435+ Hs-Source-Dirs: ./src/bin, .
425436 CPP-Options: -DPROJECTM36_VERSION="v0.1"
src/lib/ProjectM36/Base.hs−13
@@ -86,19 +86,6 @@ isRelationAtomType :: AtomType -> Bool
8686isRelationAtomType (RelationAtomType _) = True
8787isRelationAtomType _ = False
8888
89−{-
90−atomTypeForAtom :: Atom -> AtomType
91−atomTypeForAtom (IntAtom _) = IntAtomType
92−atomTypeForAtom (DoubleAtom _) = DoubleAtomType
93−atomTypeForAtom (TextAtom _) = TextAtomType
94−atomTypeForAtom (DayAtom _) = DayAtomType
95−atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType
96−atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType
97−atomTypeForAtom (BoolAtom _) = BoolAtomType
98−atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs
99−atomTypeForAtom (ConstructedAtom _ aType _) = aType
100−-}
101−
10289-- | The AttributeName is the name of an attribute in a relation.
10390type AttributeName = StringType
10491
src/lib/ProjectM36/IsomorphicSchema.hs+22−7
@@ -2,19 +2,24 @@ module ProjectM36.IsomorphicSchema where
22import ProjectM36.Base
33-- isomorphic schemas offer bi-directional functors between two schemas
44
5+--TODO: rel attrs rename or transform (needs bidirectional atom functions)
6+
7+-- 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
58--this should create a new schema
6−data IsomorphSchema = IsoRelVarName RelVarName RelVarName | --maps relvar names between schemas
9+data SchemaIsomorph = IsoRelVarName RelVarName RelVarName | --maps relvar names between schemas
710 IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName,RelVarName) | --maps one relvar into two relvars (true, false)
811 IsoUnion (RelVarName, RelVarName) RestrictionPredicateExpr RelVarName --maps two relvars to one relvar
912 -- IsoTypeConstructor in morphAttrExpr
13+
14+type SchemaIsomorphs = [SchemaIsomorph]
1015
1116{-
12−invert :: IsomorphSchema -> IsomorphSchema
17+invert :: SchemaIsomorph -> SchemaIsomorph
1318invert (IsoRelVarName nameA nameB) = IsoRelVarName nameB nameA
1419-}
1520
1621-- | Morph a relational expression in one schema to another isomorphic schema.
17−relExprMorph :: IsomorphSchema -> (RelationalExpr -> RelationalExpr)
22+relExprMorph :: SchemaIsomorph -> (RelationalExpr -> RelationalExpr)
1823-- wherever nameA is found in the expr, it must be replaced by nameB
1924relExprMorph (IsoRelVarName nameA nameB) = \expr -> case expr of
2025 RelationVariable rv () | rv == nameA -> RelationVariable nameB ()
@@ -46,7 +51,7 @@ spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate ("nonboss",
4651spam2 :: RelationalExpr
4752spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", "nonboss") TruePredicate "emp")) (RelationVariable "boss" ())
4853
49−databaseContextExprMorph :: IsomorphSchema -> (DatabaseContextExpr -> DatabaseContextExpr)
54+databaseContextExprMorph :: SchemaIsomorph -> (DatabaseContextExpr -> DatabaseContextExpr)
5055databaseContextExprMorph iso@(IsoRelVarName nameA nameB) = \expr -> case expr of
5156 Define rv attrExprs | rv == nameA -> Define nameB attrExprs
5257 Undefine rv | rv == nameA -> Undefine nameB
@@ -78,16 +83,26 @@ databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) = \expr ->
7883 --assign: replace all instances in the portion of the target relvar with the new tuples from the relExpr
7984 --problem: between the delete->insert, constraints could be violated which would not otherwise be violated in the "in" schema. This implies that there should be a combo operator which can insert/update/delete in a single pass based on relexpr queries, or perhaps MultipleExpr should be the infamous "comma" operator from TutorialD?
8085 Assign rv relExpr | rv == rvTrue -> MultipleExpr [Delete rvOut filt,
81− Insert rvOut (Restrict filt relExpr)]
86+ Insert rvOut (Restrict filt (relExprF relExpr))]
8287 Assign rv relExpr | rv == rvFalse -> MultipleExpr [Delete rvOut (NotPredicate filt),
83− Insert rvOut (Restrict (NotPredicate filt) relExpr)]
84− Insert rv relExpr | rv == rvTrue || rv == rvFalse -> Insert rvOut relExpr
88+ Insert rvOut (Restrict (NotPredicate filt) (relExprF relExpr))]
89+ Insert rv relExpr | rv == rvTrue || rv == rvFalse -> Insert rvOut (relExprF relExpr)
8590 Delete rv delPred | rv == rvTrue -> Delete rvOut (AndPredicate delPred filt)
8691 Delete rv delPred | rv == rvFalse -> Delete rvOut (AndPredicate delPred (NotPredicate filt))
8792 Update rv attrMap predi | rv == rvTrue -> Update rvOut attrMap (AndPredicate predi filt)
8893 Update rv attrMap predi | rv == rvFalse -> Update rvOut attrMap (AndPredicate (NotPredicate filt) predi)
8994 orig -> orig
95+ where
96+ relExprF = relExprMogrify (relExprMorph iso)
97+
9098databaseContextExprMogrify :: (DatabaseContextExpr -> DatabaseContextExpr) -> DatabaseContextExpr -> DatabaseContextExpr
9199databaseContextExprMogrify func (MultipleExpr exprs) = func (MultipleExpr (map func exprs))
92100databaseContextExprMogrify func orig = func orig
93101
102+-- | Apply the isomorphism transformations to the relational expression to convert the relational expression from operating on one schema to a disparate, isomorphic schema.
103+applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> RelationalExpr
104+applyRelationalExprSchemaIsomorphs morphs expr = foldl (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs
105+
106+-- | Apply the isomorphism transformations to the database context expression to convert the expression from operating on one schema to a disparate, isomorphic schema.
107+applyDatabaseCotextExprSchemaIsomorphs :: SchemaIsomorphs -> DatabaseContextExpr -> DatabaseContextExpr
108+applyDatabaseCotextExprSchemaIsomorphs morphs expr = foldl (\expr' morph -> databaseContextExprMogrify (databaseContextExprMorph morph) expr') expr morphs
test/IsomorphicSchema.hsnew file+54
@@ -0,0 +1,54 @@
1+import Test.HUnit
2+import ProjectM36.Base
3+import ProjectM36.IsomorphicSchema
4+import ProjectM36.Relation
5+import ProjectM36.RelationalExpression
6+import qualified ProjectM36.DatabaseContext as DBC
7+import qualified ProjectM36.Attribute as A
8+import System.Exit
9+import qualified Data.Map as M
10+import Control.Monad.State
11+
12+testList :: Test
13+testList = TestList [testIsoRelVarName, testIsoRestrict]
14+
15+main :: IO ()
16+main = do
17+ tcounts <- runTestTT testList
18+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
19+
20+assertEither :: (Show a) => Either a b -> IO b
21+assertEither x = case x of
22+ Left err -> assertFailure (show err) >> undefined
23+ Right val -> pure val
24+
25+testIsoRelVarName :: Test
26+testIsoRelVarName = TestCase $ do
27+ -- create a schema with two relvars and rename one while the other remains the same in the isomorphic schema
28+ let schemaA = DBC.empty {
29+ relationVariables = M.fromList [("employee", relationTrue),
30+ ("department", relationFalse)]
31+ }
32+ isomorphsAtoB = [IsoRelVarName "emp" "employee",
33+ IsoRelVarName "department" "department"]
34+ unionExpr = Union (RelationVariable "emp" ()) (RelationVariable "department" ())
35+ relResult = evalState (evalRelationalExpr (applyRelationalExprSchemaIsomorphs isomorphsAtoB unionExpr)) schemaA
36+ assertEqual "employee relation morph" (Right relationTrue) relResult
37+
38+testIsoRestrict :: Test
39+testIsoRestrict = TestCase $ do
40+ -- create a emp relation which is restricted into two boss, nonboss rel vars
41+ emprel <- assertEither $ mkRelationFromList (A.attributesFromList [Attribute "name" TextAtomType,
42+ Attribute "boss" TextAtomType])
43+ [[TextAtom "Steve", TextAtom ""],
44+ [TextAtom "Cindy", TextAtom "Steve"],
45+ [TextAtom "Sam", TextAtom "Steve"]]
46+ let schemaA = DBC.empty {
47+ relationVariables = M.singleton "employee" emprel
48+ }
49+ isomorphsAtoB = [IsoRestrict "employee" (AttributeEqualityPredicate "boss" (NakedAtomExpr (TextAtom ""))) ("nonboss", "boss")]
50+ bossq = RelationVariable "boss" ()
51+ nonbossq = RelationVariable "nonboss" ()
52+ unionq = Union (RelationVariable "boss" ()) (RelationVariable "nonboss" ())
53+ relResult = evalState (evalRelationalExpr (applyRelationalExprSchemaIsomorphs isomorphsAtoB unionq)) schemaA
54+ assertEqual "boss/nonboss union" (Right emprel) relResult