ce026c6 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

Merge branch 'transactions'

ce026c6AgentM12 years ago

README.markdown+56−6

compare with master

unifiedsplit

@@ -26,7 +26,7 @@ At this point, there are three types of command which can be executed:

261. relational algebra expressions such as:

28 ```

29−TutorialD: :s S join P

29+TutorialD (master): :showExpr S join P

30┌──────┬─────┬──┬─────┬──┬─────┬──────┬──────┐

31│CITY │COLOR│P#│PNAME│S#│SNAME│STATUS│WEIGHT│

32├──────┼─────┼──┼─────┼──┼─────┼──────┼──────┤

@@ -43,32 +43,81 @@ TutorialD: :s S join P

43└──────┴─────┴──┴─────┴──┴─────┴──────┴──────┘

44```

46− where ":s" instructs the interpreter to show the resultant relation, "S" and "P" are relation names, and "join" is the join operator.

46+ where ":show" instructs the interpreter to show the resultant relation, "S" and "P" are relation names, and "join" is the join operator.

472. interpreter-level queries such as:

49 ```

50−TutorialD: :t S

50+TutorialD (master): :type S

51{CITY "char", S# "char", SNAME "char", STATUS "char"}

52```

54 which shows the Tutorial D type for a relational expression and

56 ```

57−TutorialD: :c

57+TutorialD (master): :constraints

58fromList []

59```

60which displays database constraints.

62 ```

63−TutorialD: :p x:=S{CITY,S#,SNAME,STATUS}

63+TutorialD (master): :showplan x:=S{CITY,S#,SNAME,STATUS}

64Right (Assign "x" (RelationVariable "S"))

65```

66which displays the optimized execution plan which would have been executed to evaluate the expression.

68+TutorialD (master): :commit

69+```

70+which commits the current "disconnected" transaction which is similar to the git staging area/index.

71+

72+ ```

73+TutorialD (master): :jumphead master

74+Done.

75+```

76+which changes the current disconnected transaction to reference another head.

77+

78+ ```

79+TutorialD (master): :jump 4a4ee715-297d-49db-bfd1-afaefadc902b

80+Done.

81+```

82+which resets the current "disconnected" transaction to refer to the committed transaction specified by the UUID.

83+

84+ ```

85+TutorialD (master): :branch devel

86+Done.

87+```

88+

89+which creates a new head named "devel" in the transaction graph and resets the current "disconnected" transaction to refer to the

90+

91+ ```

92+TutorialD (devel): :rollback

93+Done.

94+```

95+

96+which resets the current "disconnected" transaction to discard any collected changes.

97+

98+ ```

99+TutorialD (devel): :showGraph

100+┌───────┬────────────────────────────────────┬──────────────────────────────────────┐

101+│current│id │parents │

102+├───────┼────────────────────────────────────┼──────────────────────────────────────┤

103+│1 │1d064d54-cd2a-4a43-822a-cbd18cf7c4e8│┌────────────────────────────────────┐│

104+│ │ ││id ││

105+│ │ │├────────────────────────────────────┤│

106+│ │ ││4a4ee715-297d-49db-bfd1-afaefadc902b││

107+│ │ │└────────────────────────────────────┘│

108+│0 │4a4ee715-297d-49db-bfd1-afaefadc902b│┌──┐ │

109+│ │ ││id│ │

110+│ │ │ │

111+│ │ │└──┘ │

112+└───────┴────────────────────────────────────┴──────────────────────────────────────┘

113+```

114+

115+which displays all committed transactions and their parents. The "current" attribute indicates to which transactions the current "disconnected" transaction refers.

116+

683. expressions which modify the database context such as:

1173. expressions which modify the database context such as:

118

70 ```

119 ```

71−TutorialD: x := S JOIN P

120+TutorialD (master): x := S JOIN P

72```

121```

73 which sets the relational variable named "x" to the results of "S join P" if the database constraint checking succeeds.

122 which sets the relational variable named "x" to the results of "S join P" if the database constraint checking succeeds.

123

@@ -77,6 +126,7 @@ TutorialD: x := S JOIN P

77 ```

126 ```

78constraint check_x false in true

127constraint check_x false in true

79```

128```

129+

80 checks that the expression "false" is a subrelation of "true", which, in this case, is always true.

130 checks that the expression "false" is a subrelation of "true", which, in this case, is always true.

131

82## Development

132## Development

Relation.hs+1−1

@@ -236,7 +236,7 @@ relMap mapper (Relation attrs tupleSet) = do

236 let remappedTuple = mapper tupleIn

237 if tupleAttributes remappedTuple == tupleAttributes tupleIn

238 then Right remappedTuple

239− else Left $ TupleAttributeTypeMismatchError 0

239+ else Left $ TupleAttributeTypeMismatchError (attributesDifference (tupleAttributes tupleIn) attrs)

240

241--in the future, the mapper should be able to return a RelationalError likely

242relMogrify :: (RelationTuple -> RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation

RelationAttribute.hs+13

@@ -3,6 +3,7 @@ import RelationType

3import qualified Data.Map as M

4import qualified Data.Set as S

5import qualified Data.List as L

6+import Debug.Trace

7renameAttribute :: AttributeName -> Attribute -> Attribute

8renameAttribute :: AttributeName -> Attribute -> Attribute

8renameAttribute newAttrName (Attribute oldAttrName typeo) = Attribute newAttrName typeo

9renameAttribute newAttrName (Attribute oldAttrName typeo) = Attribute newAttrName typeo

@@ -33,3 +34,15 @@ matchingAttributeNameSet = S.intersection

33-- this is sorted so the tuples know in which order to output- the ordering is arbitrary

34-- this is sorted so the tuples know in which order to output- the ordering is arbitrary

34sortedAttributeNameList attrNameSet= L.sort $ S.toList attrNameSet

35sortedAttributeNameList attrNameSet= L.sort $ S.toList attrNameSet

37+-- take two attribute sets and return an attribute set with the attributes which do not match

38+-- bug: missing attributes don't show up (?)

39+attributesDifference :: Attributes -> Attributes -> Attributes

40+attributesDifference attrA attrB = trace (show attrA ++ "\n" ++ show attrB) (M.union mismatchA missingB)

41+ where

42+ mismatchA = M.foldrWithKey folder M.empty attrA

43+ missingB = M.difference attrA attrB

44+ folder :: AttributeName -> Attribute -> Attributes -> Attributes

45+ folder attrName attrinA acc = if M.notMember attrName attrB || M.lookup attrName attrB /= Just attrinA then

46+ M.insert attrName attrinA acc

47+ else

48+ acc

RelationExpr.hs+1−2

@@ -82,8 +82,6 @@ evalRelationalExpr (Equals relExprA relExprB) = do

82 Left err -> return $ Left err

83 Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse

85−

86−

87emptyDatabaseContext :: DatabaseContext

85emptyDatabaseContext :: DatabaseContext

88emptyDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

86emptyDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,

89 relationVariables = M.empty}

87 relationVariables = M.empty}

@@ -339,3 +337,4 @@ predicateRestrictionFilter context (AttributeEqualityPredicate attrName atom) =

339

337

340

338

341

339

340+

RelationTerm.hs+19−6

@@ -1,6 +1,7 @@

1--writes Relation to a String suitable for terminal output

2module RelationTerm where

3import RelationType

4+import RelationTuple

4import Relation

5import Relation

5import qualified Data.Set as S

6import qualified Data.Set as S

6import qualified Data.Map as M

7import qualified Data.Map as M

@@ -48,10 +49,15 @@ cellLocations tab@(header, body) = (maxWidths, maxHeights)

48 maxHeights = map (L.maximumBy compare) rowHeights

49 maxHeights = map (L.maximumBy compare) rowHeights

49 mergeMax a b = map (\(a,b) -> max a b) (zip a b)

50 mergeMax a b = map (\(a,b) -> max a b) (zip a b)

52+--the normal "lines" function returns an empty list for an empty string which is not what we want

53+breakLines :: String -> [String]

54+breakLines "" = [""]

55+breakLines x = lines x

56+

51cellSizes :: Table -> [([Int], [Int])]

57cellSizes :: Table -> [([Int], [Int])]

52−cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . lines) row)) allRows

58+cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . breakLines) row)) allRows

53 where

59 where

54− maxRowWidth row = L.maximumBy compare (map length (lines row))

60+ maxRowWidth row = L.maximumBy compare (map length (breakLines row))

55 allRows = [header] ++ body

61 allRows = [header] ++ body

57relationAsTable :: Relation -> Table

63relationAsTable :: Relation -> Table

@@ -87,7 +93,7 @@ renderHBar left middle end columnLocations = left ++ concat (L.intersperse middl

87leftPaddedString :: Int -> Int -> String -> String

93leftPaddedString :: Int -> Int -> String -> String

88leftPaddedString lineNum size str = paddedLines !! lineNum

94leftPaddedString lineNum size str = paddedLines !! lineNum

89 where

95 where

90− paddedLines = map (\s -> s ++ repeatString (size - length s) " ") (lines str ++ repeat "")

96+ paddedLines = map (\s -> s ++ repeatString (size - length s) " ") (breakLines str ++ repeat "")

92renderRow :: [Cell] -> [Int] -> Int -> String -> String

98renderRow :: [Cell] -> [Int] -> Int -> String -> String

93renderRow cells columnLocations rowHeight interspersed = unlines $ map renderOneLine [0..rowHeight-1]

99renderRow cells columnLocations rowHeight interspersed = unlines $ map renderOneLine [0..rowHeight-1]

@@ -116,6 +122,13 @@ showRelation rel

116 | otherwise = renderTable (relationAsTable rel)

122 | otherwise = renderTable (relationAsTable rel)

117

123

118

124

119−--simpleExample = s

125+simpleExample = s

120−--groupedExample = case group (S.fromList ["CITY"]) "CITYREL" s of {Right rel -> rel}

126+groupedExample = case group (S.fromList ["CITY"]) "CITYREL" s of {Right rel -> rel}

121−

127+

128+emptyStringExample = case mkRelation attributes tupleSet of

129+ Right x -> x

130+ _ -> undefined

131+ where

132+ attributes = M.fromList [("x", Attribute "x" StringAtomType)]

133+ tupleSet = HS.singleton $ mkRelationTuple (S.fromList ["x"]) (M.singleton "x" $ StringAtom "")

134+

RelationTest.hs+1−1

@@ -41,7 +41,7 @@ validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupMapSet)

41validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation

42validateAttrTypesMatchTupleAttrTypes rel@(Relation _ tupMapSet)

43 | HS.null invalidSet = Right rel

44− | otherwise = Left (TupleAttributeTypeMismatchError 0)

44+ | otherwise = Left (TupleAttributeTypeMismatchError M.empty) --fix to include invalid attrs

45 where

46 tupleTypeCheck (RelationTuple tupMap) = M.null $ M.filterWithKey attrTypeCheck tupMap

47 attrTypeCheck attrName atomValue = case attributeTypeForName attrName rel of

RelationTupleSet.hs+2−1

@@ -1,6 +1,7 @@

1module RelationTupleSet where

2import RelationType

3import RelationTuple

4+import RelationAttribute

4import RelationalError

5import RelationalError

5import qualified Data.Map as M

6import qualified Data.Map as M

6import qualified Data.HashSet as HS

7import qualified Data.HashSet as HS

@@ -20,4 +21,4 @@ verifyRelationTupleSet attrs tupleSet = do

20 verifyTuple tuple = if tupleAttributes tuple == attrs then

21 verifyTuple tuple = if tupleAttributes tuple == attrs then

21 Right tuple

22 Right tuple

22 else

23 else

23− Left $ TupleAttributeTypeMismatchError 0

24+ Left $ TupleAttributeTypeMismatchError (attributesDifference (tupleAttributes tuple) attrs)

RelationType.hs+42−2

@@ -5,6 +5,7 @@ import qualified Data.HashSet as HS

5import qualified Data.Hashable as Hash

6import qualified Data.Set as S

7import Control.Monad.State hiding (join)

8+import Data.UUID (UUID)

9data Atom = StringAtom String |

10data Atom = StringAtom String |

10 IntAtom Int |

11 IntAtom Int |

@@ -63,7 +64,7 @@ data DatabaseContext = DatabaseContext {

63 inclusionDependencies :: HS.HashSet InclusionDependency,

64 inclusionDependencies :: HS.HashSet InclusionDependency,

64 relationVariables :: M.Map String Relation

65 relationVariables :: M.Map String Relation

65 } deriving (Show)

66 } deriving (Show)

66−

67+

67data InclusionDependency = InclusionDependency String RelationalExpr RelationalExpr deriving (Show)

68data InclusionDependency = InclusionDependency String RelationalExpr RelationalExpr deriving (Show)

69instance Hash.Hashable InclusionDependency where

70instance Hash.Hashable InclusionDependency where

@@ -93,4 +94,43 @@ data RestrictionPredicateExpr where

93 NotPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr

94 NotPredicate :: RestrictionPredicateExpr -> RestrictionPredicateExpr

94 RelationalExprPredicate :: RelationalExpr -> RestrictionPredicateExpr --type must be same as true and false relations (no attributes)

95 RelationalExprPredicate :: RelationalExpr -> RestrictionPredicateExpr --type must be same as true and false relations (no attributes)

95 AttributeEqualityPredicate :: AttributeName -> Atom -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple

96 AttributeEqualityPredicate :: AttributeName -> Atom -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple

96− deriving (Show, Eq)

97+ deriving (Show, Eq)

98+

99+-- child + parent links

100+-- the string represents the branch name and can be used to find the named HEADs

101+type HeadName = String

102+

103+type TransactionHeads = M.Map HeadName Transaction

104+

105+data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction)

106+ deriving (Show, Eq)

107+

108+transactionsForGraph :: TransactionGraph -> S.Set Transaction

109+transactionsForGraph (TransactionGraph _ t) = t

110+

111+transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

112+transactionHeadsForGraph (TransactionGraph heads _) = heads

113+

114+data TransactionInfo = TransactionInfo UUID (S.Set UUID) | -- 1 parent + n children

115+ MergeTransactionInfo UUID UUID (S.Set UUID) -- 2 parents, n children

116+ deriving(Show)

117+

118+data Transaction = Transaction UUID TransactionInfo DatabaseContext -- self uuid

119+ deriving (Show)

120+

121+--represents an "in-progress" transaction which has not yet been added to the transaction graph

122+--one the transaction is "complete", it is committed and no longer can be changed

123+-- this is similar to the index in git

124+data DisconnectedTransaction = DisconnectedTransaction UUID DatabaseContext --parentUUID, context

125+

126+transactionUUID :: Transaction -> UUID

127+transactionUUID (Transaction uuid _ _) = uuid

128+

129+transactionContext :: Transaction -> DatabaseContext

130+transactionContext (Transaction _ _ context) = context

131+

132+instance Eq Transaction where

133+ (Transaction uuidA _ _) == (Transaction uuidB _ _) = uuidA == uuidB

134+

135+instance Ord Transaction where

136+ compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB

RelationalError.hs+9−2

@@ -1,9 +1,12 @@

1module RelationalError where

2import RelationType

3+import qualified Data.UUID as U

4+import qualified Data.Set as S

4data RelationalError = NoSuchAttributeNameError String

7data RelationalError = NoSuchAttributeNameError String

5− | TupleAttributeCountMismatchError Int

8+ | TupleAttributeCountMismatchError Int --attribute name

6− | TupleAttributeTypeMismatchError Int

9+ | TupleAttributeTypeMismatchError Attributes

7 | AttributeCountMismatchError Int

10 | AttributeCountMismatchError Int

8 | AttributeNameMismatchError String

11 | AttributeNameMismatchError String

9 | AttributeNameInUseError AttributeName

12 | AttributeNameInUseError AttributeName

@@ -14,6 +17,10 @@ data RelationalError = NoSuchAttributeNameError String

14 | InclusionDependencyCheckError String

17 | InclusionDependencyCheckError String

15 | ParseError String

18 | ParseError String

16 | PredicateExpressionError String

19 | PredicateExpressionError String

20+ | NoSuchTransactionError U.UUID

21+ | NoSuchHeadNameError HeadName

22+ | TransactionIsNotAHeadError U.UUID

23+ | TransactionGraphCycleError U.UUID

17 deriving (Show,Eq)

24 deriving (Show,Eq)

RelationalTransaction.hsnew file+136

@@ -0,0 +1,136 @@

1+module RelationalTransaction where

2+import qualified Data.UUID as U

3+import RelationType

4+import RelationalError

5+import qualified Data.Set as S

6+import qualified Data.Map as M

7+import Control.Applicative ((<$>))

8+import Control.Monad

10+bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph

11+bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions

12+ where

13+ bootstrapHeads = M.singleton "master" freshTransaction

14+ freshTransaction = Transaction freshUUID (TransactionInfo U.nil S.empty) context

15+ bootstrapTransactions = S.singleton freshTransaction

16+

17+transactionForHead :: String -> TransactionGraph -> Maybe Transaction

18+transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads

19+

20+headNameForTransaction :: Transaction -> TransactionGraph -> Maybe String

21+headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then

22+ Nothing

23+ else

24+ Just $ (head . M.keys) matchingTrans

25+ where

26+ matchingTrans = M.filter (transaction ==) heads

27+

28+transactionForUUID :: U.UUID -> TransactionGraph -> Either RelationalError Transaction

29+transactionForUUID uuid graph = if S.null matchingTrans then

30+ Left $ NoSuchTransactionError uuid

31+ else

32+ Right $ head (S.toList matchingTrans)

33+ where

34+ matchingTrans = S.filter (\(Transaction uuidMatch _ _) -> uuidMatch == uuid) (transactionsForGraph graph)

35+

36+transactionsForUUIDs :: S.Set U.UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)

37+transactionsForUUIDs uuidSet graph = do

38+ transList <- forM (S.toList uuidSet) ((flip transactionForUUID) graph)

39+ return (S.fromList transList)

40+

41+isRootTransaction :: Transaction -> TransactionGraph -> Bool

42+isRootTransaction (Transaction _ (TransactionInfo pUUID _) _) graph = U.null pUUID

43+

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

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

46+parentTransactions (Transaction _ (TransactionInfo pUUID _) _) graph = do

47+ trans <- transactionForUUID pUUID graph

48+ return (S.singleton trans)

49+

50+parentTransactions (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _ ) graph = transactionsForUUIDs (S.fromList [pUUID1, pUUID2]) graph

51+

52+

53+childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

54+childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForUUIDs children

55+childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForUUIDs children

56+

57+

58+--create a disconnected transaction with a parent

59+newDisconnectedTransaction :: U.UUID -> DatabaseContext -> DisconnectedTransaction

60+newDisconnectedTransaction parentUUID context = DisconnectedTransaction parentUUID context

61+

62+{-

63+addBranch :: HeadName -> Transaction -> TransactionGraph -> Maybe TransactionGraph

64+addBranch newBranchName branchPoint graph@(TransactionGraph heads transSet) = if not (S.member branchPoint transSet) then Nothing else Just $ TransactionGraph newHeads transSet

65+ where

66+ newHeads = M.insert newBranchName branchPoint heads

67+-}

68+

69+-- create a new commit and add it to the heads

70+-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)

71+addBranch :: U.UUID -> HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

72+addBranch newUUID newBranchName branchPoint graph@(TransactionGraph heads transSet) = addTransactionToGraph newBranchName branchPoint newUUID (transactionContext branchPoint) graph

73+

74+--adds a disconnected transaction to a transaction graph at some head

75+addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

76+addDisconnectedTransaction newUUID headName dTrans@(DisconnectedTransaction parentUUID context) graph = do

77+ parentTrans <- transactionForUUID parentUUID graph

78+ addTransactionToGraph headName parentTrans newUUID context graph

79+

80+-- create a new transaction on "newHeadName" with the branchPointTrans

81+addTransactionToGraph :: HeadName -> Transaction -> U.UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

82+addTransactionToGraph newHeadName branchPointTrans@(Transaction parentUUID _ parentInfo) newUUID newContext graph@(TransactionGraph heads transSet) = do

83+ let freshTransaction = Transaction newUUID (TransactionInfo (transactionUUID branchPointTrans) S.empty) newContext

84+ -- there are two parents for MergeTransactions! not implemented

85+ --update parentTransaction to add child

86+ let parentTransaction = branchPointTrans

87+ let updatedTransSet = (S.insert freshTransaction <$> S.insert parentTransaction <$> S.delete parentTransaction) transSet

88+ let updatedGraph = TransactionGraph (M.insert newHeadName freshTransaction heads) updatedTransSet

89+ return (freshTransaction, updatedGraph)

90+

91+validateGraph :: TransactionGraph -> Maybe [RelationalError]

92+validateGraph graph@(TransactionGraph heads transSet) = do

93+ --check that all UUIDs are unique in the graph

94+ --uuids = map transactionUUID transSet

95+ --check that all heads appear in the transSet

96+ --check that all forward and backward links are in place

97+ errors <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)

98+ mapM (walkChildTransactions S.empty graph) (S.toList transSet)

99+

100+--verify that all parent links exist and that all children exist

101+--maybe verify that all parents end at UUID nil and all children end at leaves

102+walkParentTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError

103+walkParentTransactions seenTransSet graph trans =

104+ let transUUID = transactionUUID trans in

105+ if transUUID == U.nil then

106+ Nothing

107+ else if S.member transUUID seenTransSet then

108+ Just $ TransactionGraphCycleError transUUID

109+ else

110+ let parentTransSetOrError = parentTransactions trans graph in

111+ case parentTransSetOrError of

112+ Left err -> Just err

113+ Right parentTransSet -> do

114+ walk <- mapM (walkParentTransactions (S.insert transUUID seenTransSet) graph) (S.toList parentTransSet)

115+ case walk of

116+ err:xs -> Just err

117+ _ -> Nothing

118+

119+--refactor: needless duplication in these two functions

120+walkChildTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError

121+walkChildTransactions seenTransSet graph trans =

122+ let transUUID = transactionUUID trans in

123+ if childTransactions trans graph == Right S.empty then

124+ Nothing

125+ else if S.member transUUID seenTransSet then

126+ Just $ TransactionGraphCycleError transUUID

127+ else

128+ let childTransSetOrError = childTransactions trans graph in

129+ case childTransSetOrError of

130+ Left err -> Just err

131+ Right childTransSet -> do

132+ walk <- mapM (walkChildTransactions (S.insert transUUID seenTransSet) graph) (S.toList childTransSet)

133+ case walk of

134+ err:xs -> Just err

135+ _ -> Nothing

136+

RelationalTransactionShow.hsnew file+62

@@ -0,0 +1,62 @@

1+module RelationalTransactionShow where

2+import RelationType

3+import Relation

4+import RelationTuple

5+import RelationTupleSet

6+import RelationalError

7+import RelationalTransaction

8+import qualified Data.Map as M

9+import qualified Data.HashSet as HS

10+import qualified Data.Set as S

11+

12+showTransactionStructure :: Transaction -> TransactionGraph -> String

13+showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo

14+ where

15+ headInfo = maybe "" show (headNameForTransaction trans graph)

16+ parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of

17+ Left err -> show err

18+ Right parentTransSet -> concat $ S.toList $ S.map (show . transactionUUID) parentTransSet

19+

20+showGraphStructure :: TransactionGraph -> String

21+showGraphStructure graph@(TransactionGraph heads transSet) = S.foldr folder "" transSet

22+ where

23+ folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n"

24+

25+--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction

26+graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation

27+graphAsRelation discon@(DisconnectedTransaction parentUUID _) graph@(TransactionGraph heads transSet) = do

28+ tupleSet <- mapM tupleGenerator (S.toList transSet)

29+ mkRelation attributes (HS.fromList tupleSet)

30+ where

31+ attributes = M.fromList [("id", Attribute "id" StringAtomType),

32+ ("parents", Attribute "parents" (RelationAtomType parentAttributes)),

33+ ("current", Attribute "current" IntAtomType),

34+ ("head", Attribute "head" StringAtomType)

35+ ]

36+ parentAttributes = M.fromList [("id", Attribute "id" StringAtomType)]

37+ tupleGenerator transaction = case transactionParentsRelation transaction graph of

38+ Left err -> Left err

39+ Right parentTransRel -> Right $ mkRelationTuple (S.fromList ["id", "parents", "current", "head"]) $

40+ (M.fromList

41+ [("id", StringAtom $ show (transactionUUID transaction)),

42+ ("parents", RelationAtom parentTransRel),

43+ ("current", IntAtom $ if parentUUID == transactionUUID transaction then 1 else 0),

44+ ("head", StringAtom $ case headNameForTransaction transaction graph of

45+ Just headName -> headName

46+ Nothing -> "")

47+ ])

48+

49+transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation

50+transactionParentsRelation trans graph = do

51+ if isRootTransaction trans graph then do

52+ mkRelation attributes emptyTupleSet

53+ else do

54+ parentTransSet <- parentTransactions trans graph

55+ let tupleSet = HS.fromList $ map trans2tuple (S.toList parentTransSet)

56+ mkRelation attributes tupleSet

57+ where

58+ attributes = M.fromList [("id", Attribute "id" StringAtomType)]

59+ trans2tuple trans = mkRelationTuple (S.fromList ["id"]) $ M.singleton "id" (StringAtom (show $ transactionUUID trans))

60+

61+

62+

TutorialDInterpreter.hs+224−62

@@ -8,6 +8,8 @@ import RelationalError

8import RelationExpr

9import RelationTerm

10import RelationStaticOptimizer

11+import RelationalTransaction

12+import RelationalTransactionShow

11import Text.Parsec

13import Text.Parsec

12import Text.Parsec.String

14import Text.Parsec.String

13import Text.Parsec.Expr

15import Text.Parsec.Expr

@@ -22,7 +24,24 @@ import Control.Monad.State

22import System.Console.Haskeline

24import System.Console.Haskeline

23import System.IO

25import System.IO

24import System.Directory (getHomeDirectory)

26import System.Directory (getHomeDirectory)

27+import qualified Data.UUID as U

28+import Data.UUID.V4 (nextRandom)

30+{-

31+List of Tutorial D operators:

32+show relation expression type :: relexpr -> context -> opresult

33+show relvar :: relvar name -> context -> opresult

34+quit :: ()

35+show graph :: graph -> DisconnectedTransaction -> opresult

36+show constraints :: context -> opresult

37+jump to head :: head name -> graph -> DisconnectedTransaction (graph unchanged)

38+jump to UUID :: uuid -> graph -> DisconnectedTransaction (graph unchanged)

39+branch :: uuid -> branch name -> graph -> (DisconnectedTransation, graph)

40+commit :: uuid -> DisconnectedTransaction -> graph -> (DisconnectedTransaction, graph)

41+rollback :: DisconnectedTransaction -> graph -> (DisconnectedTransaction, graph)

42+

43+

44+-}

26lexer :: Token.TokenParser ()

45lexer :: Token.TokenParser ()

27lexer = Token.makeTokenParser tutD

46lexer = Token.makeTokenParser tutD

28 where tutD = emptyDef {

47 where tutD = emptyDef {

@@ -39,6 +58,13 @@ identifier = Token.identifier lexer

39comma = Token.comma lexer

58comma = Token.comma lexer

40semi = Token.semi lexer

59semi = Token.semi lexer

61+uuidP :: Parser U.UUID

62+uuidP = do

63+ uuidStr <- many (alphaNum <|> char '-')

64+ case U.fromString uuidStr of

65+ Nothing -> fail "Invalid uuid string"

66+ Just uuid -> return uuid

67+

42--used in projection

68--used in projection

43attributeList :: Parser [AttributeName]

69attributeList :: Parser [AttributeName]

44attributeList = sepBy identifier comma

70attributeList = sepBy identifier comma

@@ -244,49 +270,103 @@ parseString str = case parse (multipleDatabaseExpr <* eof) "" str of

244 Left err -> Left $ ParseError (show err)

270 Left err -> Left $ ParseError (show err)

245 Right r -> Right r

271 Right r -> Right r

246

272

247−data TutorialDOperator where

273+--operators which only rely on database context reading

274+data ContextOperator where

248− ShowRelation :: RelationalExpr -> TutorialDOperator

275+ ShowRelation :: RelationalExpr -> ContextOperator

249− ShowRelationType :: RelationalExpr -> TutorialDOperator

276+ ShowRelationType :: RelationalExpr -> ContextOperator

250− ShowConstraint :: String -> TutorialDOperator

277+ ShowConstraint :: String -> ContextOperator

251− ShowPlan :: DatabaseExpr -> TutorialDOperator

278+ ShowPlan :: DatabaseExpr -> ContextOperator

252− Quit :: TutorialDOperator

279+ Quit :: ContextOperator

253 deriving (Show)

280 deriving (Show)

281+

282+--operators which manipulate a transaction graph

283+data GraphOperator where

284+ JumpToHead :: String -> GraphOperator

285+ JumpToTransaction :: U.UUID -> GraphOperator

286+ Branch :: HeadName -> GraphOperator

287+ Commit :: GraphOperator

288+ Rollback :: GraphOperator

289+ ShowGraph :: GraphOperator

254

290

255−typeP :: Parser TutorialDOperator

291+typeP :: Parser ContextOperator

256typeP = do

292typeP = do

257− reservedOp ":t"

293+ reservedOp ":type"

258 expr <- relExpr

294 expr <- relExpr

259 return $ ShowRelationType expr

295 return $ ShowRelationType expr

260

296

261−showRelP :: Parser TutorialDOperator

297+showRelP :: Parser ContextOperator

262showRelP = do

298showRelP = do

263− reservedOp ":s"

299+ reservedOp ":showExpr"

264− expr <- relExpr <* eof

300+ expr <- relExpr

265 return $ ShowRelation expr

301 return $ ShowRelation expr

266

302

267−showPlanP :: Parser TutorialDOperator

303+showPlanP :: Parser ContextOperator

268showPlanP = do

304showPlanP = do

269− reservedOp ":p"

305+ reservedOp ":showplan"

270 expr <- databaseExpr

306 expr <- databaseExpr

271 return $ ShowPlan expr

307 return $ ShowPlan expr

272

308

273−quitP :: Parser TutorialDOperator

309+quitP :: Parser ContextOperator

274quitP = do

310quitP = do

275− reservedOp ":q"

311+ reservedOp ":quit"

276 return Quit

312 return Quit

277

313

278−showConstraintsP :: Parser TutorialDOperator

314+showConstraintsP :: Parser ContextOperator

279showConstraintsP = do

315showConstraintsP = do

280− reservedOp ":c"

316+ reservedOp ":constraints"

281 constraintName <- option "" identifier

317 constraintName <- option "" identifier

282 return $ ShowConstraint constraintName

318 return $ ShowConstraint constraintName

283

319

284−interpreterOps :: Parser TutorialDOperator

320+jumpToHeadP :: Parser GraphOperator

285−interpreterOps = typeP

321+jumpToHeadP = do

322+ reservedOp ":jumphead"

323+ head <- identifier

324+ return $ JumpToHead head

325+

326+jumpToTransactionP :: Parser GraphOperator

327+jumpToTransactionP = do

328+ reservedOp ":jump"

329+ uuid <- uuidP

330+ return $ JumpToTransaction uuid

331+

332+branchTransactionP :: Parser GraphOperator

333+branchTransactionP = do

334+ reservedOp ":branch"

335+ branchName <- identifier

336+ return $ Branch branchName

337+

338+commitTransactionP :: Parser GraphOperator

339+commitTransactionP = do

340+ reservedOp ":commit"

341+ return $ Commit

342+

343+rollbackTransactionP :: Parser GraphOperator

344+rollbackTransactionP = do

345+ reservedOp ":rollback"

346+ return $ Rollback

347+

348+showGraphP :: Parser GraphOperator

349+showGraphP = do

350+ reservedOp ":showGraph"

351+ return $ ShowGraph

352+

353+transactionGraphOps = do

354+ jumpToHeadP

355+ <|> jumpToTransactionP

356+ <|> branchTransactionP

357+ <|> commitTransactionP

358+ <|> rollbackTransactionP

359+ <|> showGraphP

360+

361+contextOps :: Parser ContextOperator

362+contextOps = typeP

286− <|> showRelP

363+ <|> showRelP

287− <|> showConstraintsP

364+ <|> showConstraintsP

288− <|> showPlanP

365+ <|> showPlanP

289− <|> quitP

366+ <|> quitP

367+

368+interpreterOps :: Parser (Either ContextOperator GraphOperator)

369+interpreterOps = liftM Left contextOps <|> liftM Right transactionGraphOps

290

370

291showRelationAttributes :: Relation -> String

371showRelationAttributes :: Relation -> String

292showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"

372showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"

@@ -300,19 +380,20 @@ showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribu

300data TutorialDOperatorResult = QuitResult |

380data TutorialDOperatorResult = QuitResult |

301 DisplayResult String |

381 DisplayResult String |

302 DisplayErrorResult String |

382 DisplayErrorResult String |

303− NoActionResult

383+ QuietSuccessResult |

384+ NoActionResult --refactor to make this dead- there should be only one parser

304

385

305−evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> TutorialDOperatorResult

386+evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult

306−evalTutorialDOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of

387+evalContextOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of

307 (Right rel, _) -> DisplayResult $ showRelationAttributes rel

388 (Right rel, _) -> DisplayResult $ showRelationAttributes rel

308 (Left err, _) -> DisplayErrorResult $ show err

389 (Left err, _) -> DisplayErrorResult $ show err

309

390

310−evalTutorialDOp context (ShowRelation expr) = do

391+evalContextOp context (ShowRelation expr) = do

311 case runState (evalRelationalExpr expr) context of

392 case runState (evalRelationalExpr expr) context of

312 (Left err, _) -> DisplayErrorResult $ show err

393 (Left err, _) -> DisplayErrorResult $ show err

313 (Right rel, _) -> DisplayResult $ showRelation rel

394 (Right rel, _) -> DisplayResult $ showRelation rel

314

395

315−evalTutorialDOp context (ShowConstraint name) = do

396+evalContextOp context (ShowConstraint name) = do

316 DisplayResult $ show filteredDeps

397 DisplayResult $ show filteredDeps

317 where

398 where

318 deps = inclusionDependencies context

399 deps = inclusionDependencies context

@@ -320,23 +401,80 @@ evalTutorialDOp context (ShowConstraint name) = do

320 "" -> deps

401 "" -> deps

321 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps

402 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps

322

403

323−evalTutorialDOp context (ShowPlan dbExpr) = do

404+evalContextOp context (ShowPlan dbExpr) = do

324 DisplayResult $ show plan

405 DisplayResult $ show plan

325 where

406 where

326 plan = evalState (applyStaticDatabaseOptimization dbExpr) context

407 plan = evalState (applyStaticDatabaseOptimization dbExpr) context

327

408

328−evalTutorialDOp context (Quit) = QuitResult

409+evalContextOp context (Quit) = QuitResult

329−

410+

330−example1 = "relA {a,b, c}"

411+-- returns the new "current" transaction, updated graph, and tutorial d result

331−example2 = "relA join relB"

412+-- the current transaction is not part of the transaction graph until it is committed

332−example3 = "relA join relB {x,y,z}"

413+evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)

333−example4 = "(relA) {x,y,z}"

414+

334−example5 = "relA union relB"

415+--affects only disconncted transaction

335−example6 = "rv1 := true"

416+evalGraphOp newUUID trans graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of

336−example7 = "rv1 := relA union relB"

417+ Left err -> Left err

337−example8 = "relA := true; relB := false"

418+ Right parentTrans -> Right (newTrans, graph, QuietSuccessResult)

338−example9 = "relA := relation { SNO CHAR }"

419+ where

420+ newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)

339

421

422+-- switch from one head to another

423+-- affects only disconnectedtransaction

424+evalGraphOp newUUID currentTransaction graph (JumpToHead headName) =

425+ case transactionForHead headName graph of

426+ Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in

427+ Right (disconnectedTrans, graph, QuietSuccessResult)

428+ Nothing -> Left $ NoSuchHeadNameError headName

429+-- add new head pointing to branchPoint

430+-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)

431+-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch

432+ {-

433+evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of

434+ Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")

435+ Just parentTrans -> case addBranch newBranchName parentTrans graph of

436+ Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")

437+ Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")

438+ where

439+ newDiscon = DisconnectedTransaction (transactionUUID parentTrans) disconContext

440+-}

441+

442+-- create a new commit and add it to the heads

443+-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)

444+evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of

445+ Left err -> Left err

446+ Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of

447+ Left err -> Left err

448+ Right (newTrans, newGraph) -> Right (newDiscon, newGraph, QuietSuccessResult)

449+ where

450+ newDiscon = DisconnectedTransaction newUUID disconContext

451+

452+-- add the disconnected transaction to the graph

453+-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction

454+evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of

455+ Left err -> Left err

456+ Right parentTransaction -> case headNameForTransaction parentTransaction graph of

457+ Nothing -> Left $ TransactionIsNotAHeadError parentUUID

458+ Just headName -> case maybeUpdatedGraph of

459+ Left err-> Left err

460+ Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph, QuietSuccessResult)

461+ where

462+ newDisconnectedTrans = newDisconnectedTransaction newTransUUID context

463+ maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph

464+

465+-- refresh the disconnected transaction, return the same graph

466+evalGraphOp _ discon@(DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of

467+ Left err -> Left err

468+ Right parentTransaction -> Right (newDiscon, graph, QuietSuccessResult)

469+ where

470+ newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)

471+

472+--display transaction graph as relation

473+evalGraphOp _ discon graph ShowGraph = do

474+ graphStr <- graphAsRelation discon graph

475+ return (discon, graph, DisplayResult $ showRelation graphStr)

476+

477+--shouldn't this be Either RelationalError DatabaseContext?

340interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)

478interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)

341interpret context tutdstring = case parseString tutdstring of

479interpret context tutdstring = case parseString tutdstring of

342 Left err -> (Just err, context)

480 Left err -> (Just err, context)

@@ -358,33 +496,53 @@ interpretNO context tutdstring = case parseString tutdstring of

358

496

359

497

360-- for interpreter-specific operations

498-- for interpreter-specific operations

361−interpretOps :: DatabaseContext -> String -> TutorialDOperatorResult

499+interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)

362−interpretOps context instring = case parse interpreterOps "" instring of

500+interpretOps newUUID trans@(DisconnectedTransaction parentUUID context) transGraph instring = case parse interpreterOps "" instring of

363− Left err -> NoActionResult

501+ Left err -> (trans, transGraph, NoActionResult)

364− Right ops -> evalTutorialDOp context ops

502+ Right ops -> case ops of

503+ Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))

504+ Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of

505+ Left err -> (trans, transGraph, DisplayErrorResult $ show err)

506+ Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)

365

507

366−reprLoop :: DatabaseContext -> IO ()

508+promptText :: DisconnectedTransaction -> TransactionGraph -> String

367−reprLoop context = do

509+promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "

510+ where

511+ transInfo = case transactionForUUID parentUUID graph of

512+ Left err -> "unknown"

513+ Right parentTrans -> case headNameForTransaction parentTrans graph of

514+ Nothing -> show $ transactionUUID parentTrans

515+ Just headName -> headName

516+

517+reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()

518+reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentContext) graph = do

368 homeDirectory <- getHomeDirectory

519 homeDirectory <- getHomeDirectory

369− let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}

520+ let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}

521+

370− maybeLine <- runInputT settings $ do

522+ maybeLine <- runInputT settings $ getInputLine (promptText currentTransaction graph)

371− getInputLine "TutorialD: "

523+

524+ let roloop = reprLoop currentTransaction graph

372 case maybeLine of

525 case maybeLine of

373 Nothing -> return ()

526 Nothing -> return ()

374 Just line -> do

527 Just line -> do

528+ newUUID <- nextRandom

375− case interpretOps context line of

529+ case interpretOps newUUID currentTransaction graph line of

376− QuitResult -> return ()

530+ (_, _, QuitResult) -> return ()

377− DisplayErrorResult err -> hPutStrLn stderr ("ERR: " ++ err) >> reprLoop context

531+ (_, _, DisplayErrorResult err) -> hPutStrLn stderr ("ERR: " ++ err) >> roloop

378− DisplayResult out -> do

532+ (updatedTrans, updatedGraph, DisplayResult out) -> do

379 putStrLn out

533 putStrLn out

380− reprLoop context

534+ reprLoop updatedTrans updatedGraph

535+ (updatedTrans, updatedGraph, QuietSuccessResult) -> do

536+ putStrLn "Done."

537+ reprLoop updatedTrans updatedGraph

381− NoActionResult -> do

538+ (_, _, NoActionResult) -> do

382− let (value, contextup) = interpret context line

539+ let (value, contextup) = interpret currentContext line

540+ let updatedTransaction = DisconnectedTransaction currentParentUUID contextup

383− case value of

541+ case value of

384− Nothing -> reprLoop contextup

542+ Nothing -> reprLoop updatedTransaction graph

385− (Just err) -> do

543+ Just err -> do

386− hPutStrLn stderr ("ERR:" ++ show err)

544+ hPutStrLn stderr ("ERR:" ++ show err)

387− reprLoop context

545+ reprLoop currentTransaction graph

388

546

389restrictionPredicateP :: Parser RestrictionPredicateExpr

547restrictionPredicateP :: Parser RestrictionPredicateExpr

390restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm

548restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm

@@ -419,4 +577,8 @@ stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")

419intAtomP = do

577intAtomP = do

420 intstr <- many digit

578 intstr <- many digit

421 return $ IntAtom (read intstr)

579 return $ IntAtom (read intstr)

422−

580+

581+--used by :dumpGraph

582+displayTransactionGraph :: TransactionGraph -> String

583+displayTransactionGraph (TransactionGraph heads transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet

584+

TutorialDInterpreterTest.hs+98−2

@@ -4,15 +4,20 @@ import RelationExpr

4import Relation

5import RelationalError

6import RelationType

7+import RelationalTransaction

7import qualified Data.HashSet as HS

8import qualified Data.HashSet as HS

8import qualified Data.Map as M

9import qualified Data.Map as M

10+import qualified Data.Set as S

9import System.Exit

11import System.Exit

12+import Data.UUID.V4 (nextRandom)

13+import Data.UUID (nil)

14+import Data.Either (isRight)

11main = do

16main = do

12 counts <- runTestTT (TestList tests)

17 counts <- runTestTT (TestList tests)

13 if errors counts + failures counts > 0 then exitFailure else exitSuccess

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

14 where

19 where

15− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests

20+ tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest]

16 simpleRelTests = [("x:=true", Right relationTrue),

21 simpleRelTests = [("x:=true", Right relationTrue),

17 ("x:=false", Right relationFalse),

22 ("x:=false", Right relationFalse),

18 ("x:=true union false", Right relationTrue),

23 ("x:=true union false", Right relationTrue),

@@ -52,4 +57,95 @@ assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interp

52 (Just err, _) -> Left err

57 (Just err, _) -> Left err

53 (Nothing, context) -> case M.lookup "x" (relationVariables context) of

58 (Nothing, context) -> case M.lookup "x" (relationVariables context) of

54 Nothing -> Left $ RelVarNotDefinedError "x"

59 Nothing -> Left $ RelVarNotDefinedError "x"

55− Just rel -> Right rel

60+ Just rel -> Right rel

61+

62+transactionGraphBasicTest = TestCase $ do

63+ (discon, graph) <- dateExamplesGraph

64+ assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing

65+

66+--add a new transaction to the graph, validate it is in the graph

67+transactionGraphAddCommitTest = TestCase $ do

68+ (discon@(DisconnectedTransaction firstUUID context), graph) <- dateExamplesGraph

69+ freshUUID <- nextRandom

70+ case interpret context "x:=S" of

71+ (Just err, newContext) -> assertFailure (show err)

72+ (Nothing, newContext) -> do

73+ let discon = newDisconnectedTransaction firstUUID newContext

74+ let addTrans = addDisconnectedTransaction freshUUID "master" discon graph

75+ case addTrans of

76+ Left err -> assertFailure (show err)

77+ Right (newTrans, graph) -> do

78+ assertBool "transaction in graph" (isRight $ transactionForUUID freshUUID graph)

79+ assertEqual "validate fresh commit with deleted S" (validateGraph graph) Nothing

80+ assertEqual "ensure S was deleted in newContext" (M.lookup "x" (relationVariables (transactionContext newTrans))) (Just s)

81+

82+transactionRollbackTest = TestCase $ do

83+ (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph

84+ freshUUID <- nextRandom

85+ case transactionForUUID firstUUID graph of

86+ Left err -> assertFailure (show err)

87+ Right firstTrans -> do

88+ case interpret origContext "x:=S" of

89+ (Just err, _) -> assertFailure (show err)

90+ (Nothing, newContext) -> do

91+ let discon = newDisconnectedTransaction firstUUID newContext

92+ let (updatedDiscon@(DisconnectedTransaction _ newContext2), newGraph, result) = interpretOps freshUUID discon graph ":rollback"

93+ assertEqual "validate context" (M.lookup "x" (relationVariables newContext2)) Nothing

94+ assertEqual "validate graph" graph newGraph

95+

96+--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present

97+transactionJumpTest = TestCase $ do

98+ (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph

99+ freshUUID <- nextRandom

100+ case transactionForUUID firstUUID graph of

101+ Left err -> assertFailure (show err)

102+ Right firstTrans -> do

103+ case interpret origContext "x:=S" of

104+ (Just err, _) -> assertFailure (show err)

105+ (Nothing, newContext) -> do

106+ --modify the second transaction

107+ case interpret newContext "x:=S" of

108+ (Just err, _) -> assertFailure (show err)

109+ (Nothing, newContext2) -> do

110+ --add the transaction

111+ let discon = newDisconnectedTransaction firstUUID newContext2

112+ let addTrans = addDisconnectedTransaction freshUUID "master" discon graph

113+ case addTrans of

114+ Left err -> assertFailure (show err)

115+ Right (newTrans, graph) -> do

116+ --jump to the first transaction

117+ let (updatedDiscon@(DisconnectedTransaction parentUUID newContext3), newGraph, result) = interpretOps freshUUID discon graph (":jump " ++ show firstUUID)

118+ assertEqual "validate discon" parentUUID firstUUID

119+ assertEqual "validate discon2" Nothing (M.lookup "x" (relationVariables newContext3))

120+ assertEqual "validate graph" transactionUUIDs (S.map transactionUUID (transactionsForGraph newGraph))

121+ where

122+ transactionUUIDs = S.fromList [firstUUID, freshUUID]

123+

124+--branch from the first transaction and verify that there are two heads

125+transactionBranchTest = TestCase $ do

126+ (origDiscon@(DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph

127+ freshUUID1 <- nextRandom

128+ freshUUID2 <- nextRandom

129+ case transactionForUUID firstUUID graph of

130+ Left err -> assertFailure (show err)

131+ Right firstTrans -> do

132+ let disconMaster = newDisconnectedTransaction firstUUID origContext

133+ let addTransMaster = addDisconnectedTransaction freshUUID1 "master" disconMaster graph

134+ --add a second transaction to the "master" branch

135+ case addTransMaster of

136+ Left err -> assertFailure (show err)

137+ Right (newTrans, graph) -> do

138+ --add a third transaction to the "test" branch

139+ let (updatedDiscon, newGraph, result) = interpretOps freshUUID2 origDiscon graph ":branch test"

140+ assertEqual "verify test head" freshUUID2 $ maybeTransUUID (transactionForHead "test" newGraph)

141+ assertEqual "verify master head" freshUUID1 $ maybeTransUUID (transactionForHead "master" newGraph)

142+ where

143+ maybeTransUUID t = maybe nil transactionUUID t

144+

145+dateExamplesGraph :: IO (DisconnectedTransaction, TransactionGraph)

146+dateExamplesGraph = do

147+ firstTransactionUUID <- nextRandom

148+ let graph = bootstrapTransactionGraph firstTransactionUUID dateExamples

149+ let discon = newDisconnectedTransaction firstTransactionUUID dateExamples

150+ return (discon, graph)

151+

project-m36.cabal+1−1

@@ -7,7 +7,7 @@ Category: Relational Algebra

7Cabal-Version: >= 1.2

9Executable tutd

10− Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory

10+ Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid

11 main-is: tutd.hs

12 GHC-Options: -fwarn-unused-imports -fwarn-unused-binds -fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns

tutd.hs+11−1

@@ -1,4 +1,14 @@

1import TutorialDInterpreter

2import RelationExpr

3+import RelationalTransaction

4+import RelationType

5+import Data.UUID.V4 (nextRandom)

7+main = do

8+ freshUUID <- nextRandom

9+ let currentHeadName = "master"

10+ let newGraph = bootstrapTransactionGraph freshUUID dateExamples

11+ let headTransaction = case transactionForHead currentHeadName newGraph of { Just x -> x; _ -> undefined}

12+ let currentTransaction = newDisconnectedTransaction (transactionUUID headTransaction) (transactionContext headTransaction)

13+ reprLoop currentTransaction newGraph

4−main = reprLoop dateExamples