3a95699 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP compilation checkpoint

commit3a9569972bcf26d824ce74a9021b0424acf74565 authorAgentM <agentm@themactionfaction.com> dateWed 11 Mar 2015, 10:57 (12 years ago) parent89eff3b

4 files changed+84−40

compare with master

unifiedsplit

RelationalError.hs+2−1 RelationalTransaction.hs+62−21 TutorialDInterpreter.hs+13−13 TutorialDInterpreterTest.hs+7−5

RelationalError.hs+2−1

@@ -17,7 +17,8 @@ data RelationalError = NoSuchAttributeNameError String

1717 | PredicateExpressionError String

1818 | NoSuchTransactionError U.UUID

1919 | NoSuchHeadNameError HeadName

20− | TransactionIsNotAHead U.UUID

20+ | TransactionIsNotAHeadError U.UUID

21+ | TransactionGraphCycleError U.UUID

2122 deriving (Show,Eq)

2223

2324

RelationalTransaction.hs+62−21

@@ -5,6 +5,7 @@ import RelationalError

55import qualified Data.Set as S

66import qualified Data.Map as M

77import Control.Applicative ((<$>))

8+import Control.Monad

910bootstrapTransactionGraph :: UUID -> DatabaseContext -> TransactionGraph

1011bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions

@@ -31,21 +32,25 @@ transactionForUUID uuid graph = if S.null matchingTrans then

3132 Right $ head (S.toList matchingTrans)

3233 where

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

34−

35+

3536transactionsForUUIDs :: S.Set UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)

36−transactionsForUUIDs uuidSet graph = S.map transactionForUUID uuidSet

37+transactionsForUUIDs uuidSet graph = do

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

39+ return (S.fromList transList)

40+

3741

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

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

40−parentTransactions (Transaction _ (TransactionInfo pUUID _)) = case transactionForUUID pUUID of

41− Just trans -> S.singleton trans

42− Nothing -> S.empty

43−parentTransactions (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _)) = transactionsForUUIDs (S.fromList [pUUID1 pUUID2])

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

45+ trans <- transactionForUUID pUUID graph

46+ return (S.singleton trans)

47+

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

4449

4550

46−childTransactions :: Transaction -> TransactionGraph -> S.Set Transaction

47−childTransactions (Transaction _ _ (TransactionInfo _ children _)) = undefined

48−childTransactions (Transaction _ _ (MergeTransactionInfo _ _ children _)) = undefined

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

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

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

4954

5055

5156--create a disconnected transaction with a parent

@@ -61,20 +66,19 @@ addBranch newBranchName branchPoint graph@(TransactionGraph heads transSet) = if

6166

6267-- create a new commit and add it to the heads

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

64−addBranch :: UUID -> HeadName -> Transaction -> TransactionGraph -> Maybe (Transaction, TransactionGraph)

69+addBranch :: UUID -> HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

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

6671

6772--adds a disconnected transaction to a transaction graph at some head

68−addDisconnectedTransaction :: UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Maybe (Transaction, TransactionGraph)

69−addDisconnectedTransaction newUUID headName dTrans@(DisconnectedTransaction parentUUID context) graph = case transactionForUUID parentUUID graph of

70− Nothing -> Nothing

71− Just parentTrans ->

72− addTransactionToGraph headName parentTrans newUUID context graph

73+addDisconnectedTransaction :: UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

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

75+ parentTrans <- transactionForUUID parentUUID graph

76+ addTransactionToGraph headName parentTrans newUUID context graph

7377

7478-- create a new transaction on "newHeadName" with the branchPointTrans

75−addTransactionToGraph :: HeadName -> Transaction -> UUID -> DatabaseContext -> TransactionGraph -> Maybe (Transaction, TransactionGraph)

79+addTransactionToGraph :: HeadName -> Transaction -> UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

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

77− let freshTransaction = Transaction newUUID (transactionUUID branchPointTrans) (TransactionInfo S.empty newContext)

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

7882 -- there are two parents for MergeTransactions! not implemented

7983 --update parentTransaction to add child

8084 let parentTransaction = branchPointTrans

@@ -83,8 +87,45 @@ addTransactionToGraph newHeadName branchPointTrans@(Transaction parentUUID _ par

8387 return (freshTransaction, updatedGraph)

8488

8589--check that all forward and backward links are in place

86−validateGraph :: TransactionGraph -> Maybe RelationalError

87−validateGraph (TransactionGraph heads transSet) = undefined

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

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

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

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

94+

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

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

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

98+walkParentTransactions seenTransSet graph trans =

99+ let transUUID = transactionUUID trans in

100+ if transUUID == nil then

101+ Nothing

102+ else if S.member transUUID seenTransSet then

103+ Just $ TransactionGraphCycleError transUUID

104+ else

105+ let parentTransSetOrError = parentTransactions trans graph in

106+ case parentTransSetOrError of

107+ Left err -> Just err

108+ Right parentTransSet -> do

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

110+ case walk of

111+ err:xs -> Just err

112+ _ -> Nothing

88113

89−validateTransaction :: Transaction -> TransactionGraph -> Maybe RelationalError

90−validateTransaction trans@(Transaction sUUID pUUID info) = undefined

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

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

116+walkChildTransactions seenTransSet graph trans =

117+ let transUUID = transactionUUID trans in

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

119+ Nothing

120+ else if S.member transUUID seenTransSet then

121+ Just $ TransactionGraphCycleError transUUID

122+ else

123+ let childTransSetOrError = childTransactions trans graph in

124+ case childTransSetOrError of

125+ Left err -> Just err

126+ Right childTransSet -> do

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

128+ case walk of

129+ err:xs -> Just err

130+ _ -> Nothing

131+

TutorialDInterpreter.hs+13−13

@@ -370,8 +370,8 @@ evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOpe

370370

371371--affects only disconncted transaction

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

373− Nothing -> Left $ NoSuchTransactionError jumpUUID

374− Just parentTrans -> Right (newTrans, graph)

373+ Left err -> Left err

374+ Right parentTrans -> Right (newTrans, graph)

375375 where

376376 newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)

377377

@@ -398,22 +398,22 @@ evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) gr

398398-- create a new commit and add it to the heads

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

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

401− Nothing -> Left $ NoSuchTransactionError parentUUID

402− Just parentTrans -> case addBranch newUUID newBranchName parentTrans graph of

403− Nothing -> Left $ NoSuchTransactionError parentUUID -- improve error

404− Just (newTrans, newGraph) -> Right (newDiscon, newGraph)

401+ Left err -> Left err

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

403+ Left err -> Left err

404+ Right (newTrans, newGraph) -> Right (newDiscon, newGraph)

405405 where

406406 newDiscon = DisconnectedTransaction newUUID disconContext

407407

408408-- add the disconnected transaction to the graph

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

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

411− Nothing -> Left $ NoSuchTransactionError parentUUID

412− Just parentTransaction -> case headNameForTransaction parentTransaction graph of

413− Nothing -> Left $ TransactionIsNotAHead parentUUID

411+ Left err -> Left err

412+ Right parentTransaction -> case headNameForTransaction parentTransaction graph of

413+ Nothing -> Left $ TransactionIsNotAHeadError parentUUID

414414 Just headName -> case maybeUpdatedGraph of

415− Nothing -> Left $ TransactionIsNotAHead parentUUID -- add better error

416− Just (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)

415+ Left err-> Left err

416+ Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)

417417 where

418418 newDisconnectedTrans = newDisconnectedTransaction newTransUUID context

419419 --parentTransaction = transactionForUUID parentUUID graph

@@ -438,8 +438,8 @@ promptText :: DisconnectedTransaction -> TransactionGraph -> String

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

439439 where

440440 transInfo = case transactionForUUID parentUUID graph of

441− Nothing -> "unknown"

442− Just parentTrans -> case headNameForTransaction parentTrans graph of

441+ Left err -> "unknown"

442+ Right parentTrans -> case headNameForTransaction parentTrans graph of

443443 Nothing -> show $ transactionUUID parentTrans

444444 Just headName -> headName

445445

TutorialDInterpreterTest.hs+7−5

@@ -4,6 +4,7 @@ import RelationExpr

44import Relation

55import RelationalError

66import RelationType

7+import RelationalTransaction

78import qualified Data.HashSet as HS

89import qualified Data.Map as M

910import System.Exit

@@ -52,14 +53,15 @@ assertTutdEqual databaseContext tutd expected = assertEqual tutd interpreted exp

5253 (Just err, _) -> Left err

5354 (Nothing, context) -> Right $ (relationVariables context) M.! "x"

5455

55−transactionGraphTest1 = TestCase $ assertEqual "validate bootstrapped graph"

56− where

57− interpreted = interpretOps U.nextRandom

58− (discon, graph) = dateExampleGraph

56+transactionGraphTest1 = TestCase $ do

57+ (discon, graph) <- dateExamplesGraph

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

59+

60+

5961

6062dateExamplesGraph :: IO (DisconnectedTransaction, TransactionGraph)

6163dateExamplesGraph = do

62− firstTransactionUUID <- U.nextRandom

64+ firstTransactionUUID <- nextRandom

6365 let graph = bootstrapTransactionGraph firstTransactionUUID dateExamples

6466 let discon = newDisconnectedTransaction firstTransactionUUID dateExamples

6567 return (discon, graph)