6990bd8 · project-m36 · git.iko.soy

.travis/install-dependencies.sh+2−2

compare with master

unifiedsplit

@@ -4,7 +4,7 @@ if [[ "$(uname)" = "Darwin" ]]; then

4else

5 timeout_cmd="timeout"

6fi

7−$timeout_cmd 15m stack --no-terminal --jobs=2 --install-ghc --system-ghc build --only-dependencies --fast

7+$timeout_cmd 30m stack --no-terminal --jobs=2 --install-ghc --system-ghc build --only-dependencies --fast

8ret=$?

9case "$ret" in

10 0)

@@ -13,7 +13,7 @@ case "$ret" in

13 124)

14 echo "Timed out while installing dependencies."

15 echo "Try building again by pushing a new commit."

16− exit 1

16+ exit 0

17 ;;

18 *)

19 echo "Failed to install dependencies; stack exited with $ret"

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+2−5

@@ -77,15 +77,12 @@ defineP = do

77undefineP :: Parser DatabaseContextExpr

78undefineP = do

79 reservedOp "undefine"

80− relVarName <- identifier

80+ Undefine <$> identifier

81− return $ Undefine relVarName

82

81

83deleteP :: Parser DatabaseContextExpr

82deleteP :: Parser DatabaseContextExpr

84deleteP = do

83deleteP = do

85 reservedOp "delete"

84 reservedOp "delete"

86− relVarName <- identifier

87− predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)

85+ Delete <$> identifier <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)

88− return $ Delete relVarName predicate

89

86

90updateP :: Parser DatabaseContextExpr

87updateP :: Parser DatabaseContextExpr

91updateP = do

88updateP = do

src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+5−10

@@ -30,20 +30,17 @@ data RODatabaseContextOperator where

30typeP :: Parser RODatabaseContextOperator

31typeP = do

32 reservedOp ":type"

33− expr <- relExprP

33+ ShowRelationType <$> relExprP

34− return $ ShowRelationType expr

35

34

36showRelP :: Parser RODatabaseContextOperator

35showRelP :: Parser RODatabaseContextOperator

37showRelP = do

36showRelP = do

38 reservedOp ":showexpr"

37 reservedOp ":showexpr"

39− expr <- relExprP

38+ ShowRelation <$> relExprP

40− return $ ShowRelation expr

41

39

42showPlanP :: Parser RODatabaseContextOperator

40showPlanP :: Parser RODatabaseContextOperator

43showPlanP = do

41showPlanP = do

44 reservedOp ":showplan"

42 reservedOp ":showplan"

45− expr <- databaseContextExprP

43+ ShowPlan <$> databaseContextExprP

46− return $ ShowPlan expr

47

44

48showTypesP :: Parser RODatabaseContextOperator

45showTypesP :: Parser RODatabaseContextOperator

49showTypesP = reserved ":showtypes" >> pure ShowTypes

46showTypesP = reserved ":showtypes" >> pure ShowTypes

@@ -59,14 +56,12 @@ quitP = do

59showConstraintsP :: Parser RODatabaseContextOperator

56showConstraintsP :: Parser RODatabaseContextOperator

60showConstraintsP = do

57showConstraintsP = do

61 reservedOp ":constraints"

58 reservedOp ":constraints"

62− constraintName <- option "" identifier

59+ ShowConstraint <$> option "" identifier

63− return $ ShowConstraint constraintName

64

60

65plotRelExprP :: Parser RODatabaseContextOperator

61plotRelExprP :: Parser RODatabaseContextOperator

66plotRelExprP = do

62plotRelExprP = do

67 reserved ":plotexpr"

63 reserved ":plotexpr"

68− expr <- relExprP

64+ PlotRelation <$> relExprP

69− return $ PlotRelation expr

70

65

71roDatabaseContextOperatorP :: Parser RODatabaseContextOperator

66roDatabaseContextOperatorP :: Parser RODatabaseContextOperator

72roDatabaseContextOperatorP = typeP

67roDatabaseContextOperatorP = typeP

src/bin/TutorialD/Interpreter/RelationalExpr.hs+8−16

@@ -112,8 +112,7 @@ ungroupP = do

112extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

113extendP = do

114 reservedOp ":"

115− tupleExpr <- braces extendTupleExpressionP

115+ Extend <$> braces extendTupleExpressionP

116− return $ Extend tupleExpr

117

116

118semijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)

117semijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)

119semijoinP = do

118semijoinP = do

@@ -169,17 +168,15 @@ restrictionPredicateP = makeExprParser predicateTerm predicateOperators

169 <|> relationalBooleanExprP

168 <|> relationalBooleanExprP

170

169

171relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

170relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

172−relationalBooleanExprP = do

171+relationalBooleanExprP =

173− relexpr <- parens relExprP <|> relTerm

174 --we can't actually detect if the type is relational boolean, so we just pass it to the next phase

172 --we can't actually detect if the type is relational boolean, so we just pass it to the next phase

175− return $ RelationalExprPredicate relexpr

173+ RelationalExprPredicate <$> (parens relExprP <|> relTerm)

176

174

177restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

175restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

178restrictionAttributeEqualityP = do

176restrictionAttributeEqualityP = do

179 attributeName <- identifier

177 attributeName <- identifier

180 reservedOp "="

178 reservedOp "="

181− atomexpr <- atomExprP

182− return $ AttributeEqualityPredicate attributeName atomexpr

179+ AttributeEqualityPredicate attributeName <$> atomExprP

183

180

184restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"

181restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"

185restrictionAtomExprP = do

182restrictionAtomExprP = do

@@ -196,8 +193,7 @@ attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTuple

196attributeExtendTupleExpressionP = do

193attributeExtendTupleExpressionP = do

197 newAttr <- identifier

194 newAttr <- identifier

198 reservedOp ":="

195 reservedOp ":="

199− atom <- atomExprP

200− return $ AttributeExtendTupleExpr newAttr atom

196+ AttributeExtendTupleExpr newAttr <$> atomExprP

201

197

202atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

198atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

203atomExprP = consumeAtomExprP True

199atomExprP = consumeAtomExprP True

@@ -213,8 +209,7 @@ consumeAtomExprP consume = try functionAtomExprP <|>

213attributeAtomExprP :: Parser (AtomExprBase a)

209attributeAtomExprP :: Parser (AtomExprBase a)

214attributeAtomExprP = do

210attributeAtomExprP = do

215 _ <- string "@"

211 _ <- string "@"

216− attrName <- identifier

212+ AttributeAtomExpr <$> identifier

217− return $ AttributeAtomExpr attrName

218

213

219nakedAtomExprP :: Parser (AtomExprBase a)

214nakedAtomExprP :: Parser (AtomExprBase a)

220nakedAtomExprP = NakedAtomExpr <$> atomP

215nakedAtomExprP = NakedAtomExpr <$> atomP

@@ -234,11 +229,8 @@ atomP = stringAtomP <|>

234 boolAtomP

229 boolAtomP

235

230

236functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

231functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

237−functionAtomExprP = do

232+functionAtomExprP =

238− funcName <- identifier

239− argList <- parens (sepBy atomExprP comma)

233+ FunctionAtomExpr <$> identifier <*> parens (sepBy atomExprP comma) <*> parseMarkerP

240− marker <- parseMarkerP

241− return $ FunctionAtomExpr funcName argList marker

242

234

243relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

235relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)

244relationalAtomExprP = RelationAtomExpr <$> relExprP

236relationalAtomExprP = RelationAtomExpr <$> relExprP

src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs+3−6

@@ -22,14 +22,12 @@ autoMergeToHeadP = do

22jumpToHeadP :: Parser TransactionGraphOperator

23jumpToHeadP = do

24 reservedOp ":jumphead"

25− headid <- identifier

25+ JumpToHead <$> identifier

26− return $ JumpToHead headid

27

26

28jumpToTransactionP :: Parser TransactionGraphOperator

27jumpToTransactionP :: Parser TransactionGraphOperator

29jumpToTransactionP = do

28jumpToTransactionP = do

30 reservedOp ":jump"

29 reservedOp ":jump"

31− uuid <- uuidP

30+ JumpToTransaction <$> uuidP

32− return $ JumpToTransaction uuid

33

31

34walkBackToTimeP :: Parser TransactionGraphOperator

32walkBackToTimeP :: Parser TransactionGraphOperator

35walkBackToTimeP = do

33walkBackToTimeP = do

@@ -39,8 +37,7 @@ walkBackToTimeP = do

39branchTransactionP :: Parser TransactionGraphOperator

37branchTransactionP :: Parser TransactionGraphOperator

40branchTransactionP = do

38branchTransactionP = do

41 reservedOp ":branch"

39 reservedOp ":branch"

42− branchName <- identifier

40+ Branch <$> identifier

43− return $ Branch branchName

44

41

45deleteBranchP :: Parser TransactionGraphOperator

42deleteBranchP :: Parser TransactionGraphOperator

46deleteBranchP = do

43deleteBranchP = do

src/lib/ProjectM36/Base.hs+1−3

@@ -58,9 +58,7 @@ instance Hashable Atom where

58

59instance Binary UTCTime where

60 put utc = put $ toRational (utcTimeToPOSIXSeconds utc)

61− get = do

62− r <- get :: Get Rational

61+ get = posixSecondsToUTCTime . fromRational <$> (get :: Get Rational)

63− return (posixSecondsToUTCTime (fromRational r))

64

62

65instance Binary Day where

63instance Binary Day where

66 put day = put $ toGregorian day

64 put day = put $ toGregorian day

src/lib/ProjectM36/Client.hs+16−6

@@ -582,7 +582,7 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither

582 pure (Right ())

583executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

584

585−-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing).

585+-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead.

586autoMergeToHead :: SessionId -> Connection -> MergeStrategy -> HeadName -> IO (Either RelationalError ())

587autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do

588 let sessions = ipSessions conf

@@ -594,11 +594,21 @@ autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do

594 eSession <- sessionForSessionId sessionId sessions

595 case eSession of

596 Left err -> pure (Left err)

597− Right session ->

597+ Right session ->

598+ case Graph.transactionForHead headName' graph of

599+ Nothing -> pure (Left (NoSuchHeadNameError headName'))

600+ Just headTrans -> do

601+ --attempt fast-forward commit, if possible

602+ let graphInfo = if Sess.parentId session == transactionId headTrans then do

603+ ret <- Graph.evalGraphOp stamp id1 (Sess.disconnectedTransaction session) graph Commit

604+ pure (ret, [id1])

605+ else do

598− case Graph.autoMergeToHead stamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph of

606+ ret <- Graph.autoMergeToHead stamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph

607+ pure (ret, [id1,id2,id3])

608+ case graphInfo of

599− Left err -> pure (Left err)

609+ Left err -> pure (Left err)

600− Right (discon', graph') ->

610+ Right ((discon', graph'), transactionIdsAdded) ->

601− pure (Right (discon', graph', [id1, id2, id3]))

611+ pure (Right (discon', graph', transactionIdsAdded))

602autoMergeToHead sessionId conn@(RemoteProcessConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName')

612autoMergeToHead sessionId conn@(RemoteProcessConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName')

603

613

604-- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr`s modify the DatabaseContext but cannot be purely implemented.

614-- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr`s modify the DatabaseContext but cannot be purely implemented.

src/lib/ProjectM36/Client/Simple.hs+1−1

@@ -72,7 +72,7 @@ close (_ , conn) = C.close conn

72withTransaction :: DbConn -> Db a -> IO (Either DbError a)

73withTransaction sessconn = withTransactionUsing sessconn UnionMergeStrategy

74

75−-- | Same a 'withTransaction' except that the merge strategy can be specified.

75+-- | Same as 'withTransaction' except that the merge strategy can be specified.

76withTransactionUsing :: DbConn -> MergeStrategy -> Db a -> IO (Either DbError a)

77withTransactionUsing (sess, conn) strat dbm = do

78 eHeadName <- C.headName sess conn

src/lib/ProjectM36/Relation.hs+3−5

@@ -37,9 +37,8 @@ atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType

37atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs

38

39mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation

40−mkRelationFromList attrs atomMatrix = do

40+mkRelationFromList attrs atomMatrix =

41− tupSet <- mkTupleSetFromList attrs atomMatrix

41+ Relation attrs <$> mkTupleSetFromList attrs atomMatrix

42− return $ Relation attrs tupSet

43

42

44emptyRelationWithAttrs :: Attributes -> Relation

43emptyRelationWithAttrs :: Attributes -> Relation

45emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet

44emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet

@@ -220,8 +219,7 @@ join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = do

220 joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2

219 joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2

221 return $ joinedTupSet ++ accumulator

220 return $ joinedTupSet ++ accumulator

222 newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1)

221 newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1)

223− newTupSet <- mkTupleSet newAttrs newTupSetList

222+ Relation newAttrs <$> mkTupleSet newAttrs newTupSetList

224− return $ Relation newAttrs newTupSet

225

223

226-- | Difference takes two relations of the same type and returns a new relation which contains only tuples which appear in the first relation but not the second.

224-- | Difference takes two relations of the same type and returns a new relation which contains only tuples which appear in the first relation but not the second.

227difference :: Relation -> Relation -> Either RelationalError Relation

225difference :: Relation -> Relation -> Either RelationalError Relation

src/lib/ProjectM36/Relation/Parse/CSV.hs+1−1

@@ -57,7 +57,7 @@ csvAsRelation attrs tConsMap inString = case APBL.parse (csvWithHeader csvDecode

57

58

59parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser (Either RelationalError Atom)

60−parseCSVAtomP _ _ IntegerAtomType = (Right . IntegerAtom) <$> APT.decimal

60+parseCSVAtomP _ _ IntegerAtomType = Right . IntegerAtom <$> APT.decimal

61parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal

62parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double

63parseCSVAtomP _ _ TextAtomType = do

src/lib/ProjectM36/Transaction/Persist.hs+8−9

@@ -23,9 +23,9 @@ import qualified Data.ByteString as BS

23import qualified Data.ByteString.Lazy as BSL

24

25getDirectoryNames :: FilePath -> IO [FilePath]

26−getDirectoryNames path = do

26+getDirectoryNames path =

27− subpaths <- getDirectoryContents path

28− return $ filter (\n -> n `notElem` ["..", "."]) subpaths

27+ filter (\ n -> n `notElem` ["..", "."]) <$> getDirectoryContents path

28+

29

30tempTransactionDir :: FilePath -> TransactionId -> FilePath

31tempTransactionDir dbdir transId = dbdir </> "." ++ show transId

@@ -109,10 +109,10 @@ readRelVars :: FilePath -> IO (M.Map RelVarName Relation)

109readRelVars transDir = do

110 let relvarsPath = relvarsDir transDir

111 relvarNames <- getDirectoryNames relvarsPath

112− relvars <- mapM (\name -> do

112+ let relvars = mapM (\name -> do

113 rel <- B.decode . decompress . BSL.fromStrict <$> BS.readFile (relvarsPath </> name)

114 return (T.pack name, rel)) relvarNames

115− return $ M.fromList relvars

115+ M.fromList <$> relvars

116

117writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO ()

118writeAtomFuncs sync transDir funcs = do

@@ -191,8 +191,8 @@ readDBCFuncs transDir mScriptSession = do

191 funcNames <- getDirectoryNames (dbcFuncsDir transDir)

192 --only Haskell script functions can be serialized

193 --we always return the pre-compiled functions

194− funcs <- mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames

194+ let funcs = mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames

195− return $ HS.union basicDatabaseContextFunctions (HS.fromList funcs)

195+ HS.union basicDatabaseContextFunctions . HS.fromList <$> funcs

196

197readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction

198readDBCFunc transDir funcName mScriptSession precompiledFuncs = do

@@ -232,8 +232,7 @@ readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)

232readIncDeps transDir = do

233 let incDepsPath = incDepsDir transDir

234 incDepNames <- getDirectoryNames incDepsPath

235− incDeps <- mapM (readIncDep transDir . T.pack) incDepNames

235+ M.fromList <$> mapM (readIncDep transDir . T.pack) incDepNames

236− return $ M.fromList incDeps

237

236

238readSubschemas :: FilePath -> IO Subschemas

237readSubschemas :: FilePath -> IO Subschemas

239readSubschemas transDir = do

238readSubschemas transDir = do

src/lib/ProjectM36/TransactionGraph.hs+5−6

@@ -98,9 +98,8 @@ transactionForId tid graph

98 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)

99

100transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)

101−transactionsForIds idSet graph = do

101+transactionsForIds idSet graph =

102− transList <- forM (S.toList idSet) (`transactionForId` graph)

102+ S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)

103− return (S.fromList transList)

104

103

105isRootTransaction :: Transaction -> TransactionGraph -> Bool

104isRootTransaction :: Transaction -> TransactionGraph -> Bool

106isRootTransaction (Transaction _ (TransactionInfo pId _ _) _) _ = U.null pId

105isRootTransaction (Transaction _ (TransactionInfo pId _ _) _) _ = U.null pId

@@ -108,9 +107,9 @@ isRootTransaction (Transaction _ MergeTransactionInfo{} _) _ = False

108

107

109-- the first transaction has no parent - all other do have parents- merges have two parents

108-- the first transaction has no parent - all other do have parents- merges have two parents

110parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

109parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

111−parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph = do

110+parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph =

112− trans <- transactionForId pId graph

111+ S.singleton <$> transactionForId pId graph

113− return (S.singleton trans)

112+

114

113

115parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph

114parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph

116

115

src/lib/ProjectM36/TransactionGraph/Persist.hs+1−3

@@ -211,7 +211,5 @@ readGraphTransactionIdFile dbdir = do

211 (readUUID tid, readEpoch epochText, map readUUID parentIds)

212 readUUID uuidText = fromMaybe (error "failed to read uuid") (U.fromText uuidText)

213 readEpoch t = posixSecondsToUTCTime (realToFrac (either (error "failed to read epoch") fst (double t)))

214− --warning: uses lazy IO

215− graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

216− return $ Right (map grapher $ T.lines graphTransactionIdData)

214+ Right . map grapher . T.lines <$> TIO.readFile (transactionLogPath dbdir)

217

215

src/lib/ProjectM36/Tuple.hs+2−3

@@ -56,9 +56,8 @@ atomTypeForAttributeName attrName tup = do

56-}

57

58atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> Either RelationalError (V.Vector Atom)

59−atomsForAttributeNames attrNames tuple = do

59+atomsForAttributeNames attrNames tuple =

60− vindices <- vectorIndicesForAttributeNames attrNames (tupleAttributes tuple)

61− return $ V.map (\index -> tupleAtoms tuple V.! index) vindices

60+ V.map (\index -> tupleAtoms tuple V.! index) <$> vectorIndicesForAttributeNames attrNames (tupleAttributes tuple)

62

61

63vectorIndicesForAttributeNames :: V.Vector AttributeName -> Attributes -> Either RelationalError (V.Vector Int)

62vectorIndicesForAttributeNames :: V.Vector AttributeName -> Attributes -> Either RelationalError (V.Vector Int)

64vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNames then

63vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNames then

test/Client/Simple.hs+14−8

@@ -3,11 +3,14 @@ import Test.HUnit

3import System.Exit

4import ProjectM36.Relation

5import qualified ProjectM36.Client as C

6+import ProjectM36.DateExamples

7+import ProjectM36.DatabaseContext

6import System.IO.Temp

8import System.IO.Temp

7import System.FilePath

9import System.FilePath

8import ProjectM36.TupleSet

10import ProjectM36.TupleSet

9import ProjectM36.Attribute

11import ProjectM36.Attribute

10import qualified Data.Vector as V

12import qualified Data.Vector as V

13+import qualified Data.Map as M

11

14

12main :: IO ()

15main :: IO ()

13main = do

16main = do

@@ -15,7 +18,7 @@ main = do

15 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

18 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

16

19

17testList :: Test

20testList :: Test

18−testList = TestList [testSimpleCommitSuccess, testSimpleCommitFailure]

21+testList = TestList [testSimpleCommitSuccess, testSimpleCommitFailure, testSimpleUpdate]

19

22

20assertEither :: (Show a) => IO (Either a b) -> IO b

23assertEither :: (Show a) => IO (Either a b) -> IO b

21assertEither x = do

24assertEither x = do

@@ -45,6 +48,7 @@ testSimpleCommitSuccess = TestCase $

45 eRes <- C.executeRelationalExpr sess conn relExpr

48 eRes <- C.executeRelationalExpr sess conn relExpr

46 assertEqual "x and y" (Right relationTrue) eRes

49 assertEqual "x and y" (Right relationTrue) eRes

47

50

51+

48testSimpleCommitFailure :: Test

52testSimpleCommitFailure :: Test

49testSimpleCommitFailure = TestCase $ do

53testSimpleCommitFailure = TestCase $ do

50 let failAttrs = attributesFromList [Attribute "fail" IntAtomType]

54 let failAttrs = attributesFromList [Attribute "fail" IntAtomType]

@@ -57,11 +61,13 @@ testSimpleCommitFailure = TestCase $ do

57 execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet)

61 execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet)

58 let expectedErr = Left (RelError (RelationTypeMismatchError V.empty failAttrs))

62 let expectedErr = Left (RelError (RelationTypeMismatchError V.empty failAttrs))

59 assertEqual "dbc error" expectedErr err

63 assertEqual "dbc error" expectedErr err

60−

61−

62−

63

64

64−

65+-- #176 default merge couldn't handle Update

65−

66+testSimpleUpdate :: Test

66−

67+testSimpleUpdate = TestCase $ do

67−

68+ let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []

69+ dbconn <- assertEither (simpleConnectProjectM36 connInfo)

70+ assertEither $ withTransaction dbconn $

71+ execute $ databaseContextAsDatabaseContextExpr dateExamples

72+ assertEither $ withTransaction dbconn $

73+ execute $ Update "s" (M.singleton "sname" (C.NakedAtomExpr (C.TextAtom "Blakey"))) (C.AttributeEqualityPredicate "sname" (C.NakedAtomExpr (C.TextAtom "Blake")))

test/Relation/StaticOptimizer.hs+3−9

@@ -124,18 +124,12 @@ testPushDownRestrictionPredicate :: Test

124testPushDownRestrictionPredicate = TestCase $ do

125 -- (s union relation{tuple{city "Boston", s# "S6", sname "Stevens", status 50}}) where status = 30 == (s where status=30) union (relation{tuple{city "Boston", s# "S6", sname "Stevens", status 50}} where status=30)

126 let rvs = RelationVariable "s" ()

127− stevens <- case mkRelationFromList (attributes suppliersRel) [

128− [TextAtom "S6", TextAtom "Stevens", IntegerAtom 50, TextAtom "Boston"]] of

129− Left err -> assertFailure ("stevens relation: " ++ show err) >> pure relationTrue

130− Right rel -> pure rel

131− let expr1 = Restrict status30 (Union rvs (ExistingRelation stevens))

132− status30 = AttributeEqualityPredicate "status" (NakedAtomExpr (IntAtom 30))

127+ let status30 = AttributeEqualityPredicate "status" (NakedAtomExpr (IntAtom 30))

133 relationsOrError = do

128 relationsOrError = do

134 stevens <- mkRelationFromList (attributes suppliersRel) [[TextAtom "S6", TextAtom "Stevens", IntegerAtom 50, TextAtom "Boston"]]

129 stevens <- mkRelationFromList (attributes suppliersRel) [[TextAtom "S6", TextAtom "Stevens", IntegerAtom 50, TextAtom "Boston"]]

135− let expr1 = Restrict status30 (Union rvs (ExistingRelation stevens))

130+ let expectedExpr1 = Union (Restrict status30 rvs) (Restrict status30 (ExistingRelation stevens))

136− status30 = AttributeEqualityPredicate "status" (NakedAtomExpr (IntAtom 30))

131+ expr1 = Restrict status30 (Union rvs (ExistingRelation stevens))

137

132

138− expectedExpr1 = Union (Restrict status30 rvs) (Restrict status30 (ExistingRelation stevens))

139 pure (expectedExpr1, applyStaticRestrictionPushdown expr1)

133 pure (expectedExpr1, applyStaticRestrictionPushdown expr1)

140 either (assertFailure . (++) "stevens relation: " . show) (uncurry $ assertEqual "union restriction pushdown") relationsOrError

134 either (assertFailure . (++) "stevens relation: " . show) (uncurry $ assertEqual "union restriction pushdown") relationsOrError

141

135