89eff3b · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP transaction support

89eff3bAgentM12 years ago

RelationExpr.hs+1−2

compare with master

unifiedsplit

@@ -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}

@@ -316,3 +314,4 @@ predicateRestrictionFilter context (AttributeEqualityPredicate attrName atom) =

316

314

317

315

318

316

317+

RelationTupleSet.hs−1

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

3import RelationTuple

4import RelationalError

5import qualified Data.Map as M

6−import qualified Data.Set as S

7import qualified Data.HashSet as HS

6import qualified Data.HashSet as HS

8import Control.Monad

7import Control.Monad

RelationType.hs+40−5

@@ -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 |

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

64 inclusionDependencies :: HS.HashSet InclusionDependency,

65 inclusionDependencies :: HS.HashSet InclusionDependency,

65 relationVariables :: M.Map String Relation

66 relationVariables :: M.Map String Relation

66 } deriving (Show)

67 } deriving (Show)

67−

68+

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

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

70instance Hash.Hashable InclusionDependency where

71instance Hash.Hashable InclusionDependency where

@@ -97,8 +98,42 @@ data RestrictionPredicateExpr where

98-- child + parent links

99-- child + parent links

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

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

100−data Transaction = Transaction UUID String Transaction (S.Set Transaction) |

101+type HeadName = String

102+

103+type TransactionHeads = M.Map HeadName Transaction

104+

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

106+ deriving (Show)

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+

101− MergeTransaction UUID Transaction Transaction |

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

102− NullTransaction -- the first transaction has no parent, a current head has no children

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 --parent UUID

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

103

134

104−--data NamedHeads = NamedHeads M.Map String Transaction

135+instance Ord Transaction where

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

137+

138+

139+

RelationalError.hs+4

@@ -1,5 +1,6 @@

1module RelationalError where

2import RelationType

3+import qualified Data.UUID as U

4data RelationalError = NoSuchAttributeNameError String

5data RelationalError = NoSuchAttributeNameError String

5 | TupleAttributeCountMismatchError Int

6 | TupleAttributeCountMismatchError Int

@@ -14,6 +15,9 @@ data RelationalError = NoSuchAttributeNameError String

14 | InclusionDependencyCheckError String

15 | InclusionDependencyCheckError String

15 | ParseError String

16 | ParseError String

16 | PredicateExpressionError String

17 | PredicateExpressionError String

18+ | NoSuchTransactionError U.UUID

19+ | NoSuchHeadNameError HeadName

20+ | TransactionIsNotAHead U.UUID

17 deriving (Show,Eq)

21 deriving (Show,Eq)

RelationalTransaction.hsnew file+90

@@ -0,0 +1,90 @@

1+module RelationalTransaction where

2+import Data.UUID (UUID, nil)

3+import RelationType

4+import RelationalError

5+import qualified Data.Set as S

6+import qualified Data.Map as M

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

9+bootstrapTransactionGraph :: UUID -> DatabaseContext -> TransactionGraph

10+bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions

11+ where

12+ bootstrapHeads = M.singleton "master" freshTransaction

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

14+ bootstrapTransactions = S.singleton freshTransaction

15+

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

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

18+

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

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

21+ Nothing

22+ else

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

24+ where

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

26+

27+transactionForUUID :: UUID -> TransactionGraph -> Either RelationalError Transaction

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

29+ Left $ NoSuchTransactionError uuid

30+ else

31+ Right $ head (S.toList matchingTrans)

32+ where

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

34+

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

36+transactionsForUUIDs uuidSet graph = S.map transactionForUUID uuidSet

37+

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

39+parentTransactions :: 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+

45+

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

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

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

49+

50+

51+--create a disconnected transaction with a parent

52+newDisconnectedTransaction :: UUID -> DatabaseContext -> DisconnectedTransaction

53+newDisconnectedTransaction parentUUID context = DisconnectedTransaction parentUUID context

54+

55+{-

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

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

58+ where

59+ newHeads = M.insert newBranchName branchPoint heads

60+-}

61+

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

63+-- 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)

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

66+

67+--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+

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

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

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

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

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

79+ --update parentTransaction to add child

80+ let parentTransaction = branchPointTrans

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

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

83+ return (freshTransaction, updatedGraph)

84+

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

86+validateGraph :: TransactionGraph -> Maybe RelationalError

87+validateGraph (TransactionGraph heads transSet) = undefined

88+

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

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

TutorialDInterpreter.hs+182−57

@@ -7,6 +7,7 @@ import RelationTupleSet

7import RelationalError

8import RelationExpr

9import RelationTerm

10+import RelationalTransaction

10import Text.Parsec

11import Text.Parsec

11import Text.Parsec.String

12import Text.Parsec.String

12import Text.Parsec.Expr

13import Text.Parsec.Expr

@@ -21,14 +22,16 @@ import Control.Monad.State

21import System.Console.Haskeline

22import System.Console.Haskeline

22import System.IO

23import System.IO

23import System.Directory (getHomeDirectory)

24import System.Directory (getHomeDirectory)

25+import qualified Data.UUID as U

26+import Data.UUID.V4 (nextRandom)

25lexer :: Token.TokenParser ()

28lexer :: Token.TokenParser ()

26lexer = Token.makeTokenParser tutD

29lexer = Token.makeTokenParser tutD

27 where tutD = emptyDef {

30 where tutD = emptyDef {

28 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],

31 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],

29 Token.reservedNames = [],

32 Token.reservedNames = [],

30− Token.identStart = letter <|> char '_',

33+ Token.identStart = letter <|> char '_' <|> char '#',

31− Token.identLetter = alphaNum <|> char '_'}

34+ Token.identLetter = alphaNum <|> char '_' <|> char '#'}

33parens = Token.parens lexer

36parens = Token.parens lexer

34reservedOp = Token.reservedOp lexer

37reservedOp = Token.reservedOp lexer

@@ -38,6 +41,13 @@ identifier = Token.identifier lexer

38comma = Token.comma lexer

41comma = Token.comma lexer

39semi = Token.semi lexer

42semi = Token.semi lexer

44+uuidP :: Parser U.UUID

45+uuidP = do

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

47+ case U.fromString uuidStr of

48+ Nothing -> fail "Invalid uuid string"

49+ Just uuid -> return uuid

50+

41--used in projection

51--used in projection

42attributeList :: Parser [AttributeName]

52attributeList :: Parser [AttributeName]

43attributeList = sepBy identifier comma

53attributeList = sepBy identifier comma

@@ -235,41 +245,89 @@ parseString str = case parse multipleDatabaseExpr "" str of

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

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

236 Right r -> Right r

246 Right r -> Right r

237

247

238−data TutorialDOperator where

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

249+data ContextOperator where

239− ShowRelation :: RelationalExpr -> TutorialDOperator

250+ ShowRelation :: RelationalExpr -> ContextOperator

240− ShowRelationType :: RelationalExpr -> TutorialDOperator

251+ ShowRelationType :: RelationalExpr -> ContextOperator

241− ShowConstraint :: String -> TutorialDOperator

252+ ShowConstraint :: String -> ContextOperator

242− Quit :: TutorialDOperator

253+ Quit :: ContextOperator

254+ deriving (Show)

255+

256+--operators which manipulate a transaction graph

257+data GraphOperator where

258+ JumpToHead :: String -> GraphOperator

259+ JumpToTransaction :: U.UUID -> GraphOperator

260+ Branch :: HeadName -> GraphOperator

261+ Commit :: GraphOperator

262+ Rollback :: GraphOperator

243 deriving (Show)

263 deriving (Show)

244

264

245−typeP :: Parser TutorialDOperator

265+typeP :: Parser ContextOperator

246typeP = do

266typeP = do

247− reservedOp ":t"

267+ reservedOp ":type"

248 expr <- relExpr

268 expr <- relExpr

249 return $ ShowRelationType expr

269 return $ ShowRelationType expr

250

270

251−showRelP :: Parser TutorialDOperator

271+showRelP :: Parser ContextOperator

252showRelP = do

272showRelP = do

253− reservedOp ":s"

273+ reservedOp ":show"

254 expr <- relExpr

274 expr <- relExpr

255 return $ ShowRelation expr

275 return $ ShowRelation expr

256

276

257−quitP :: Parser TutorialDOperator

277+quitP :: Parser ContextOperator

258quitP = do

278quitP = do

259− reservedOp ":q"

279+ reservedOp ":quit"

260 return Quit

280 return Quit

261

281

262−showConstraintsP :: Parser TutorialDOperator

282+showConstraintsP :: Parser ContextOperator

263showConstraintsP = do

283showConstraintsP = do

264− reservedOp ":c"

284+ reservedOp ":constraints"

265 constraintName <- option "" identifier

285 constraintName <- option "" identifier

266 return $ ShowConstraint constraintName

286 return $ ShowConstraint constraintName

267

287

268−interpreterOps :: Parser TutorialDOperator

288+jumpToHeadP :: Parser GraphOperator

269−interpreterOps = typeP

289+jumpToHeadP = do

290+ reservedOp ":jumphead"

291+ head <- identifier

292+ return $ JumpToHead head

293+

294+jumpToTransactionP :: Parser GraphOperator

295+jumpToTransactionP = do

296+ reservedOp ":jump"

297+ uuid <- uuidP

298+ return $ JumpToTransaction uuid

299+

300+branchTransactionP :: Parser GraphOperator

301+branchTransactionP = do

302+ reservedOp ":branch"

303+ branchName <- identifier

304+ return $ Branch branchName

305+

306+commitTransactionP :: Parser GraphOperator

307+commitTransactionP = do

308+ reservedOp ":commit"

309+ return $ Commit

310+

311+rollbackTransactionP :: Parser GraphOperator

312+rollbackTransactionP = do

313+ reservedOp ":rollback"

314+ return $ Rollback

315+

316+transactionGraphOps = do

317+ jumpToHeadP

318+ <|> jumpToTransactionP

319+ <|> branchTransactionP

320+ <|> commitTransactionP

321+ <|> rollbackTransactionP

322+

323+contextOps :: Parser ContextOperator

324+contextOps = typeP

270− <|> showRelP

325+ <|> showRelP

271− <|> showConstraintsP

326+ <|> showConstraintsP

272− <|> quitP

327+ <|> quitP

328+

329+interpreterOps :: Parser (Either ContextOperator GraphOperator)

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

273

331

274showRelationAttributes :: Relation -> String

332showRelationAttributes :: Relation -> String

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

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

@@ -285,17 +343,17 @@ data TutorialDOperatorResult = QuitResult |

285 DisplayErrorResult String |

343 DisplayErrorResult String |

286 NoActionResult

344 NoActionResult

287

345

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

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

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

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

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

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

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

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

292

350

293−evalTutorialDOp context (ShowRelation expr) = do

351+evalContextOp context (ShowRelation expr) = do

294 case runState (evalRelationalExpr expr) context of

352 case runState (evalRelationalExpr expr) context of

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

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

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

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

297

355

298−evalTutorialDOp context (ShowConstraint name) = do

356+evalContextOp context (ShowConstraint name) = do

299 DisplayResult $ show filteredDeps

357 DisplayResult $ show filteredDeps

300 where

358 where

301 deps = inclusionDependencies context

359 deps = inclusionDependencies context

@@ -303,51 +361,114 @@ evalTutorialDOp context (ShowConstraint name) = do

303 "" -> deps

361 "" -> deps

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

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

305

363

364+--I need to pass the transaction graph around instead of the singular context :/

306−evalTutorialDOp context (Quit) = QuitResult

365+evalContextOp context (Quit) = QuitResult

307−

366+

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

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

309−example2 = "relA join relB"

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

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

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

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

370+

312−example5 = "relA union relB"

371+--affects only disconncted transaction

313−example6 = "rv1 := true"

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

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

373+ Nothing -> Left $ NoSuchTransactionError jumpUUID

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

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

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

375+ where

376+ newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)

317

377

378+-- switch from one head to another

379+-- affects only disconnectedtransaction

380+evalGraphOp newUUID currentTransaction graph (JumpToHead headName) =

381+ case transactionForHead headName graph of

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

383+ Right (disconnectedTrans, graph)

384+ Nothing -> Left $ NoSuchHeadNameError headName

385+-- add new head pointing to branchPoint

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

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

388+ {-

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

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

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

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

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

394+ where

395+ newDiscon = DisconnectedTransaction (transactionUUID parentTrans) disconContext

396+-}

397+

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

399+-- 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)

400+evalGraphOp 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)

405+ where

406+ newDiscon = DisconnectedTransaction newUUID disconContext

407+

408+-- add the disconnected transaction to the graph

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

410+evalGraphOp 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

414+ Just headName -> case maybeUpdatedGraph of

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

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

417+ where

418+ newDisconnectedTrans = newDisconnectedTransaction newTransUUID context

419+ --parentTransaction = transactionForUUID parentUUID graph

420+ maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph

421+

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

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

319interpret context tutdstring = case parseString tutdstring of

423interpret context tutdstring = case parseString tutdstring of

320 Left err -> (Just err, context)

424 Left err -> (Just err, context)

321 Right parsed -> runState (evalContextExpr parsed) context

425 Right parsed -> runState (evalContextExpr parsed) context

322

426

323-- for interpreter-specific operations

427-- for interpreter-specific operations

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

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

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

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

326− Left err -> NoActionResult

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

327− Right ops -> evalTutorialDOp context ops

431+ Right ops -> case ops of

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

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

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

435+ Right (newDiscon, newGraph) -> (newDiscon, newGraph, DisplayResult "Done.")

328

436

329−reprLoop :: DatabaseContext -> IO ()

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

330−reprLoop context = do

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

439+ where

440+ transInfo = case transactionForUUID parentUUID graph of

441+ Nothing -> "unknown"

442+ Just parentTrans -> case headNameForTransaction parentTrans graph of

443+ Nothing -> show $ transactionUUID parentTrans

444+ Just headName -> headName

445+

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

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

331 homeDirectory <- getHomeDirectory

448 homeDirectory <- getHomeDirectory

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

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

450+

333− maybeLine <- runInputT settings $ do

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

334− getInputLine "TutorialD: "

452+

453+ let roloop = reprLoop currentTransaction graph

335 case maybeLine of

454 case maybeLine of

336 Nothing -> return ()

455 Nothing -> return ()

337 Just line -> do

456 Just line -> do

457+ newUUID <- nextRandom

338− case interpretOps context line of

458+ case interpretOps newUUID currentTransaction graph line of

339− QuitResult -> return ()

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

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

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

341− DisplayResult out -> do

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

342 putStrLn out

462 putStrLn out

343− reprLoop context

463+ reprLoop updatedTrans updatedGraph

344− NoActionResult -> do

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

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

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

466+ let updatedTransaction = DisconnectedTransaction currentParentUUID contextup

346− case value of

467+ case value of

347− Nothing -> reprLoop contextup

468+ Nothing -> reprLoop updatedTransaction graph

348− (Just err) -> do

469+ Just err -> do

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

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

350− reprLoop context

471+ reprLoop currentTransaction graph

351

472

352restrictionPredicateP :: Parser RestrictionPredicateExpr

473restrictionPredicateP :: Parser RestrictionPredicateExpr

353restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm

474restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm

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

382intAtomP = do

503intAtomP = do

383 intstr <- many digit

504 intstr <- many digit

384 return $ IntAtom (read intstr)

505 return $ IntAtom (read intstr)

385−

506+

507+--used by :dumpGraph

508+displayTransactionGraph :: TransactionGraph -> String

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

510+

TutorialDInterpreterTest.hs+15−1

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

7import qualified Data.HashSet as HS

8import qualified Data.Map as M

9import System.Exit

10+import Data.UUID.V4 (nextRandom)

11main = do

12main = do

12 counts <- runTestTT (TestList tests)

13 counts <- runTestTT (TestList tests)

@@ -49,4 +50,17 @@ assertTutdEqual databaseContext tutd expected = assertEqual tutd interpreted exp

49 where

50 where

50 interpreted = case interpret databaseContext tutd of

51 interpreted = case interpret databaseContext tutd of

51 (Just err, _) -> Left err

52 (Just err, _) -> Left err

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

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

54+

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

56+ where

57+ interpreted = interpretOps U.nextRandom

58+ (discon, graph) = dateExampleGraph

59+

60+dateExamplesGraph :: IO (DisconnectedTransaction, TransactionGraph)

61+dateExamplesGraph = do

62+ firstTransactionUUID <- U.nextRandom

63+ let graph = bootstrapTransactionGraph firstTransactionUUID dateExamples

64+ let discon = newDisconnectedTransaction firstTransactionUUID dateExamples

65+ return (discon, graph)

66+

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

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