@@ -8,6 +8,8 @@ import RelationalError
88import RelationExpr
99import RelationTerm
1010import RelationStaticOptimizer
11+import RelationalTransaction
12+import RelationalTransactionShow
1113import Text.Parsec
1214import Text.Parsec.String
1315import Text.Parsec.Expr
@@ -22,7 +24,24 @@ import Control.Monad.State
2224import System.Console.Haskeline
2325import System.IO
2426import System.Directory (getHomeDirectory)
27+import qualified Data.UUID as U
28+import Data.UUID.V4 (nextRandom)
2529
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+-}
2645lexer :: Token.TokenParser ()
2746lexer = Token.makeTokenParser tutD
2847 where tutD = emptyDef {
@@ -39,6 +58,13 @@ identifier = Token.identifier lexer
3958comma = Token.comma lexer
4059semi = Token.semi lexer
4160
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+
4268--used in projection
4369attributeList :: Parser [AttributeName]
4470attributeList = sepBy identifier comma
@@ -244,49 +270,103 @@ parseString str = case parse (multipleDatabaseExpr <* eof) "" str of
244270 Left err -> Left $ ParseError (show err)
245271 Right r -> Right r
246272
247−data TutorialDOperator where
248− ShowRelation :: RelationalExpr -> TutorialDOperator
249− ShowRelationType :: RelationalExpr -> TutorialDOperator
250− ShowConstraint :: String -> TutorialDOperator
251− ShowPlan :: DatabaseExpr -> TutorialDOperator
252− Quit :: TutorialDOperator
273+--operators which only rely on database context reading
274+data ContextOperator where
275+ ShowRelation :: RelationalExpr -> ContextOperator
276+ ShowRelationType :: RelationalExpr -> ContextOperator
277+ ShowConstraint :: String -> ContextOperator
278+ ShowPlan :: DatabaseExpr -> ContextOperator
279+ Quit :: ContextOperator
253280 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
254290
255−typeP :: Parser TutorialDOperator
291+typeP :: Parser ContextOperator
256292typeP = do
257− reservedOp ":t"
293+ reservedOp ":type"
258294 expr <- relExpr
259295 return $ ShowRelationType expr
260296
261−showRelP :: Parser TutorialDOperator
297+showRelP :: Parser ContextOperator
262298showRelP = do
263− reservedOp ":s"
264− expr <- relExpr <* eof
299+ reservedOp ":showExpr"
300+ expr <- relExpr
265301 return $ ShowRelation expr
266302
267−showPlanP :: Parser TutorialDOperator
303+showPlanP :: Parser ContextOperator
268304showPlanP = do
269− reservedOp ":p"
305+ reservedOp ":showplan"
270306 expr <- databaseExpr
271307 return $ ShowPlan expr
272308
273−quitP :: Parser TutorialDOperator
309+quitP :: Parser ContextOperator
274310quitP = do
275− reservedOp ":q"
311+ reservedOp ":quit"
276312 return Quit
277313
278−showConstraintsP :: Parser TutorialDOperator
314+showConstraintsP :: Parser ContextOperator
279315showConstraintsP = do
280− reservedOp ":c"
316+ reservedOp ":constraints"
281317 constraintName <- option "" identifier
282318 return $ ShowConstraint constraintName
283319
284−interpreterOps :: Parser TutorialDOperator
285−interpreterOps = typeP
286− <|> showRelP
287− <|> showConstraintsP
288− <|> showPlanP
289− <|> quitP
320+jumpToHeadP :: Parser GraphOperator
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
363+ <|> showRelP
364+ <|> showConstraintsP
365+ <|> showPlanP
366+ <|> quitP
367+
368+interpreterOps :: Parser (Either ContextOperator GraphOperator)
369+interpreterOps = liftM Left contextOps <|> liftM Right transactionGraphOps
290370
291371showRelationAttributes :: Relation -> String
292372showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
@@ -300,19 +380,20 @@ showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribu
300380data TutorialDOperatorResult = QuitResult |
301381 DisplayResult String |
302382 DisplayErrorResult String |
303− NoActionResult
383+ QuietSuccessResult |
384+ NoActionResult --refactor to make this dead- there should be only one parser
304385
305−evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> TutorialDOperatorResult
306−evalTutorialDOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
386+evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult
387+evalContextOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
307388 (Right rel, _) -> DisplayResult $ showRelationAttributes rel
308389 (Left err, _) -> DisplayErrorResult $ show err
309390
310−evalTutorialDOp context (ShowRelation expr) = do
391+evalContextOp context (ShowRelation expr) = do
311392 case runState (evalRelationalExpr expr) context of
312393 (Left err, _) -> DisplayErrorResult $ show err
313394 (Right rel, _) -> DisplayResult $ showRelation rel
314395
315−evalTutorialDOp context (ShowConstraint name) = do
396+evalContextOp context (ShowConstraint name) = do
316397 DisplayResult $ show filteredDeps
317398 where
318399 deps = inclusionDependencies context
@@ -320,23 +401,80 @@ evalTutorialDOp context (ShowConstraint name) = do
320401 "" -> deps
321402 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
322403
323−evalTutorialDOp context (ShowPlan dbExpr) = do
404+evalContextOp context (ShowPlan dbExpr) = do
324405 DisplayResult $ show plan
325406 where
326407 plan = evalState (applyStaticDatabaseOptimization dbExpr) context
327408
328−evalTutorialDOp context (Quit) = QuitResult
329−
330−example1 = "relA {a,b, c}"
331−example2 = "relA join relB"
332−example3 = "relA join relB {x,y,z}"
333−example4 = "(relA) {x,y,z}"
334−example5 = "relA union relB"
335−example6 = "rv1 := true"
336−example7 = "rv1 := relA union relB"
337−example8 = "relA := true; relB := false"
338−example9 = "relA := relation { SNO CHAR }"
409+evalContextOp context (Quit) = QuitResult
410+
411+-- returns the new "current" transaction, updated graph, and tutorial d result
412+-- the current transaction is not part of the transaction graph until it is committed
413+evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
414+
415+--affects only disconncted transaction
416+evalGraphOp newUUID trans graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
417+ Left err -> Left err
418+ Right parentTrans -> Right (newTrans, graph, QuietSuccessResult)
419+ where
420+ newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
339421
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?
340478interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
341479interpret context tutdstring = case parseString tutdstring of
342480 Left err -> (Just err, context)
@@ -358,33 +496,53 @@ interpretNO context tutdstring = case parseString tutdstring of
358496
359497
360498-- for interpreter-specific operations
361−interpretOps :: DatabaseContext -> String -> TutorialDOperatorResult
362−interpretOps context instring = case parse interpreterOps "" instring of
363− Left err -> NoActionResult
364− Right ops -> evalTutorialDOp context ops
499+interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
500+interpretOps newUUID trans@(DisconnectedTransaction parentUUID context) transGraph instring = case parse interpreterOps "" instring of
501+ Left err -> (trans, transGraph, NoActionResult)
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)
365507
366−reprLoop :: DatabaseContext -> IO ()
367−reprLoop context = do
508+promptText :: DisconnectedTransaction -> TransactionGraph -> String
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
368519 homeDirectory <- getHomeDirectory
369− let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
370− maybeLine <- runInputT settings $ do
371− getInputLine "TutorialD: "
520+ let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
521+
522+ maybeLine <- runInputT settings $ getInputLine (promptText currentTransaction graph)
523+
524+ let roloop = reprLoop currentTransaction graph
372525 case maybeLine of
373526 Nothing -> return ()
374527 Just line -> do
375− case interpretOps context line of
376− QuitResult -> return ()
377− DisplayErrorResult err -> hPutStrLn stderr ("ERR: " ++ err) >> reprLoop context
378− DisplayResult out -> do
528+ newUUID <- nextRandom
529+ case interpretOps newUUID currentTransaction graph line of
530+ (_, _, QuitResult) -> return ()
531+ (_, _, DisplayErrorResult err) -> hPutStrLn stderr ("ERR: " ++ err) >> roloop
532+ (updatedTrans, updatedGraph, DisplayResult out) -> do
379533 putStrLn out
380− reprLoop context
381− NoActionResult -> do
382− let (value, contextup) = interpret context line
383− case value of
384− Nothing -> reprLoop contextup
385− (Just err) -> do
386− hPutStrLn stderr ("ERR:" ++ show err)
387− reprLoop context
534+ reprLoop updatedTrans updatedGraph
535+ (updatedTrans, updatedGraph, QuietSuccessResult) -> do
536+ putStrLn "Done."
537+ reprLoop updatedTrans updatedGraph
538+ (_, _, NoActionResult) -> do
539+ let (value, contextup) = interpret currentContext line
540+ let updatedTransaction = DisconnectedTransaction currentParentUUID contextup
541+ case value of
542+ Nothing -> reprLoop updatedTransaction graph
543+ Just err -> do
544+ hPutStrLn stderr ("ERR:" ++ show err)
545+ reprLoop currentTransaction graph
388546
389547restrictionPredicateP :: Parser RestrictionPredicateExpr
390548restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
@@ -419,4 +577,8 @@ stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
419577intAtomP = do
420578 intstr <- many digit
421579 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+