diff --git a/project-m36.cabal b/project-m36.cabal index 5884d60e..10073cf6 100644 --- a/project-m36.cabal +++ b/project-m36.cabal @@ -463,7 +463,7 @@ Executable bigrel Common commontest Default-Language: Haskell2010 - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256, scientific, streamly + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256, scientific, streamly, optics-core Default-Extensions: OverloadedStrings GHC-Options: -Wall -threaded -with-rtsopts=-N Hs-Source-Dirs: test, src/bin diff --git a/test/IsomorphicSchema.hs b/test/IsomorphicSchema.hs index 33778b82..33a0e303 100644 --- a/test/IsomorphicSchema.hs +++ b/test/IsomorphicSchema.hs @@ -1,11 +1,13 @@ import Test.HUnit import ProjectM36.Base import ProjectM36.Error +import ProjectM36.IsomorphicSchema.Types import ProjectM36.IsomorphicSchema import ProjectM36.Relation import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph import ProjectM36.StaticOptimizer +import ProjectM36.DatabaseContext (_relationVariables, relationVariables) import qualified ProjectM36.DatabaseContext as DBC import qualified ProjectM36.DatabaseContext.Basic as DBC import ProjectM36.Attribute (attributesFromList) @@ -39,7 +41,7 @@ assertMaybe x msg = case x of testSchemaValidation :: Test testSchemaValidation = TestCase $ do let potentialSchema = DBC.basicDatabaseContext { - relationVariables = M.singleton "anotherRel" (ExistingRelation relationTrue) + _relationVariables = M.singleton "anotherRel" (ExistingRelation relationTrue) } -- missing relvars failure morphs = [IsoRename "true" "true", IsoRename "false" "false"] @@ -54,7 +56,7 @@ testIsoRename :: Test testIsoRename = TestCase $ do -- create a schema with two relvars and rename one while the other remains the same in the isomorphic schema let ctx = DBC.empty { - relationVariables = M.fromList [("employee", ExistingRelation relationTrue), + _relationVariables = M.fromList [("employee", ExistingRelation relationTrue), ("department", ExistingRelation relationFalse)] } (graph, _) <- freshTransactionGraph ctx @@ -84,7 +86,7 @@ testIsoRestrict = TestCase $ do let schemaA = mkRelationalExprEnv baseContext graph baseContext = DBC.empty { - relationVariables = M.fromList [("nonboss", ExistingRelation nonBossRel), + _relationVariables = M.fromList [("nonboss", ExistingRelation nonBossRel), ("boss", ExistingRelation bossRel)] } isomorphsAtoB = [IsoRestrict "employee" predicate ("boss", "nonboss")] @@ -136,7 +138,7 @@ testIsoUnion = TestCase $ do [TextAtom "Auto", IntegerAtom 200], [TextAtom "Tractor", IntegerAtom 500]] let env = mkRelationalExprEnv (DBC.basicDatabaseContext & - relationVariables ~. M.singleton "motor" (ExistingRelation motorsRel) + relationVariables .~ M.singleton "motor" (ExistingRelation motorsRel) ) graph splitPredicate = AtomExprPredicate (FunctionAtomExpr "lt" [AttributeAtomExpr "power", NakedAtomExpr (IntegerAtom 50)] ()) splitIsomorphs = [IsoUnion ("lowpower", "highpower") splitPredicate "motor", diff --git a/test/SQL/InterpreterTest.hs b/test/SQL/InterpreterTest.hs index b2fab605..a50fcc53 100644 --- a/test/SQL/InterpreterTest.hs +++ b/test/SQL/InterpreterTest.hs @@ -25,6 +25,7 @@ import Text.Megaparsec import qualified Data.Text as T import qualified Data.Map as M import TutorialD.Printer +import Optics.Core main :: IO () main = do @@ -56,7 +57,7 @@ testFindColumn = TestCase $ do testSelect :: Test testSelect = TestCase $ do -- check that SQL and tutd compile to same thing - let sqlDBContext = dateExamples { relationVariables = M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples) } + let sqlDBContext = dateExamples & relationVariables ~. M.insert "snull" (ExistingRelation sNullRelVar) (dateExamples ^. relationVariables) (tgraph,transId) <- freshTransactionGraph sqlDBContext (sess, conn) <- dateExamplesConnection emptyNotificationCallback @@ -333,7 +334,7 @@ testSelect = TestCase $ do testCreateTable :: Test testCreateTable = TestCase $ do - let sqlDBContext = dateExamples { relationVariables = M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples) } + let sqlDBContext = dateExamples { _relationVariables = M.insert "snull" (ExistingRelation sNullRelVar) (dateExamples ^. relationVariables) } (tgraph,transId) <- freshTransactionGraph sqlDBContext let createTableTests = [ @@ -396,9 +397,9 @@ testCreateTable = TestCase $ do testDBUpdate :: Test testDBUpdate = TestCase $ do - let sqlDBContext = dateExamples { relationVariables = + let sqlDBContext = dateExamples { _relationVariables = M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples), - typeConstructorMapping = typeConstructorMapping dateExamples <> nullTypeConstructorMapping + _typeConstructorMapping = dateExamples ^. typeConstructorMapping <> nullTypeConstructorMapping } (tgraph,transId) <- freshTransactionGraph sqlDBContext diff --git a/test/Server/Main.hs b/test/Server/Main.hs index 54499978..96b97771 100644 --- a/test/Server/Main.hs +++ b/test/Server/Main.hs @@ -5,6 +5,7 @@ test client/server interaction import Test.HUnit import ProjectM36.Client import qualified ProjectM36.Client as C +import ProjectM36.IsomorphicSchema.Types import ProjectM36.Server import ProjectM36.Server.Config import ProjectM36.Relation diff --git a/test/TransactionGraph/Merge.hs b/test/TransactionGraph/Merge.hs index 3a3ee42b..86174b90 100644 --- a/test/TransactionGraph/Merge.hs +++ b/test/TransactionGraph/Merge.hs @@ -3,15 +3,18 @@ import Test.HUnit import ProjectM36.Base import ProjectM36.Attribute import ProjectM36.Relation -import ProjectM36.Transaction import ProjectM36.TransactionInfo as TI import ProjectM36.TransactionGraph +import ProjectM36.IsomorphicSchema.Types +import ProjectM36.TransactionGraph.Types import ProjectM36.Error import ProjectM36.Key import qualified ProjectM36.DisconnectedTransaction as Discon -import qualified ProjectM36.DatabaseContext as DBC +import ProjectM36.DatabaseContext (DatabaseContext(..),relationVariables, inclusionDependencies,asDatabaseContext) +import qualified ProjectM36.DatabaseContext.Basic as DBC import ProjectM36.RelationalExpression import ProjectM36.StaticOptimizer +import ProjectM36.Transaction.Types import qualified Data.ByteString.Lazy as BS import System.Exit @@ -22,6 +25,7 @@ import qualified Data.Map as M import Data.Maybe import Data.Time.Clock import Data.Time.Calendar +import Optics.Core {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} @@ -52,7 +56,7 @@ root 1 -} createTrans :: TransactionId -> TransactionInfo -> DatabaseContext -> Transaction -createTrans tid info ctx = Transaction tid info (Schemas ctx M.empty) +createTrans tid info' ctx = Transaction tid info' (Schemas ctx M.empty) basicTransactionGraph :: IO TransactionGraph basicTransactionGraph = do @@ -169,7 +173,7 @@ testSelectedBranchMerge = TestCase $ do --validate that the branchB relvar does *not* appear in the merge because branchA was selected mergeTrans <- assertEither (transactionForId (fakeUUID 4) graph'') - assertBool "branchOnlyRelvar is present in merge" (M.notMember "branchBOnlyRelvar" (relationVariables (concreteDatabaseContext mergeTrans))) + assertBool "branchOnlyRelvar is present in merge" (M.notMember "branchBOnlyRelvar" (concreteDatabaseContext mergeTrans ^. relationVariables)) -- try various individual component conflicts and check for resolution testUnionPreferMergeStrategy :: Test @@ -179,9 +183,9 @@ testUnionPreferMergeStrategy = TestCase $ do branchATrans <- assertMaybe (transactionForHead "branchA" graph) "branchATrans" branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "branchBTrans" branchBRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) [] - let branchAContext = (concreteDatabaseContext branchATrans) {relationVariables = M.insert conflictRelVarName branchARelVar (relationVariables (concreteDatabaseContext branchATrans))} + let branchAContext = concreteDatabaseContext branchATrans & relationVariables .~ M.insert conflictRelVarName branchARelVar (concreteDatabaseContext branchATrans ^. relationVariables) branchARelVar = ExistingRelation relationTrue - branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName (ExistingRelation branchBRelVar) (relationVariables (concreteDatabaseContext branchBTrans))} + branchBContext = concreteDatabaseContext branchBTrans & relationVariables .~ M.insert conflictRelVarName (ExistingRelation branchBRelVar) (concreteDatabaseContext branchBTrans ^. relationVariables) conflictRelVarName = "conflictRelVar" (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchATrans) testTime) branchAContext) graph @@ -192,8 +196,8 @@ testUnionPreferMergeStrategy = TestCase $ do case merged of Left err -> assertFailure ("expected merge success: " ++ show err) Right (discon, _) -> do - let Just rvExpr = M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon)) - reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph + let Just rvExpr = M.lookup conflictRelVarName (Discon.concreteDatabaseContext discon ^. relationVariables) + reEnv = freshGraphRefRelationalExprEnv (Just (asDatabaseContext (Discon.concreteDatabaseContext discon))) graph let eRvRel = runGraphRefRelationalExprM reEnv (evalGraphRefRelationalExpr rvExpr) assertEqual "branchB relvar preferred in conflict" (Right branchBRelVar) eRvRel @@ -208,8 +212,8 @@ testUnionMergeStrategy = TestCase $ do -- add another relvar to branchB - branchBOnlyRelvar should appear in the merge -- add inclusion dependency in branchA - let updatedBranchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert branchBOnlyRelVarName branchBOnlyRelVar (relationVariables (concreteDatabaseContext branchBTrans)) } - updatedBranchAContext = (concreteDatabaseContext branchATrans) {inclusionDependencies = M.insert branchAOnlyIncDepName branchAOnlyIncDep (inclusionDependencies (concreteDatabaseContext branchATrans)) } + let updatedBranchBContext = concreteDatabaseContext branchBTrans & relationVariables .~ M.insert branchBOnlyRelVarName branchBOnlyRelVar (concreteDatabaseContext branchBTrans ^. relationVariables) + updatedBranchAContext = concreteDatabaseContext branchATrans & inclusionDependencies .~ M.insert branchAOnlyIncDepName branchAOnlyIncDep (concreteDatabaseContext branchATrans ^. inclusionDependencies) branchBOnlyRelVar = ExistingRelation relationTrue branchAOnlyIncDepName = "branchAOnlyIncDep" branchBOnlyRelVarName = "branchBOnlyRelVar" @@ -217,9 +221,9 @@ testUnionMergeStrategy = TestCase $ do (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TI.singleParent (transactionId branchBTrans) testTime) updatedBranchBContext) graph let env = freshGraphRefRelationalExprEnv Nothing graph' (discon, _) <- assertEither $ runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") - let Just rvExpr = M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon)) + let Just rvExpr = M.lookup branchBOnlyRelVarName (Discon.concreteDatabaseContext discon ^. relationVariables) Right rvRel = runGraphRefRelationalExprM reEnv (evalGraphRefRelationalExpr rvExpr) - reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph + reEnv = freshGraphRefRelationalExprEnv (Just (asDatabaseContext (Discon.concreteDatabaseContext discon))) graph assertEqual "branchBOnlyRelVar should appear in the merge" relationTrue rvRel (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TI.singleParent (transactionId branchATrans) testTime) updatedBranchAContext) graph' @@ -233,14 +237,14 @@ testUnionMergeStrategy = TestCase $ do let mergeContext = concreteDatabaseContext mergeTrans assertEqual "merge transaction parents" (parentIds mergeTrans) (S.fromList [fakeUUID 3, fakeUUID 4]) -- check that the new merge tranasction has elements from both A and B branches - let Just rvExpr' = M.lookup branchBOnlyRelVarName (relationVariables mergeContext) + let Just rvExpr' = M.lookup branchBOnlyRelVarName (mergeContext ^. relationVariables) Right rvRel' = runGraphRefRelationalExprM reEnv' (evalGraphRefRelationalExpr rvExpr') reEnv' = freshGraphRefRelationalExprEnv (Just mergeContext) graph assertEqual "merge transaction relvars" relationTrue rvRel' - assertEqual "merge transaction incdeps" (Just branchAOnlyIncDep) (M.lookup branchAOnlyIncDepName (inclusionDependencies mergeContext)) + assertEqual "merge transaction incdeps" (Just branchAOnlyIncDep) (M.lookup branchAOnlyIncDepName (mergeContext ^. inclusionDependencies)) -- test an expected conflict- add branchBOnlyRelVar with same name but different attributes conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) [] - let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName (ExistingRelation conflictRelVar) (relationVariables updatedBranchAContext) } + let conflictContextA = updatedBranchAContext & relationVariables .~ M.insert branchBOnlyRelVarName (ExistingRelation conflictRelVar) (updatedBranchAContext ^. relationVariables) conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict" (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TI.singleParent (transactionId conflictBranchATrans) testTime) conflictContextA) graph'' let failingMerge = runGraphRefRelationalExprM gfEnv' $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") @@ -263,9 +267,9 @@ testUnionMergeIncDepViolation = TestCase $ do rvName = "x" Right branchArv = eRel 2 Right branchBrv = eRel 3 - branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName (ExistingRelation branchArv)} - branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName (ExistingRelation branchBrv), - inclusionDependencies = M.singleton incDepName incDep} + branchAContext = (concreteDatabaseContext branchBTrans) {_relationVariables = M.singleton rvName (ExistingRelation branchArv)} + branchBContext = (concreteDatabaseContext branchBTrans) { _relationVariables = M.singleton rvName (ExistingRelation branchBrv), + _inclusionDependencies = M.singleton incDepName incDep} incDepName = "x_key" incDep = inclusionDependencyForKey (AttributeNames (S.singleton "x")) (RelationVariable "x" ())