@@ -7,6 +7,7 @@ import RelationTupleSet
77import RelationalError
88import RelationExpr
99import RelationTerm
10+import RelationalTransaction
1011import Text.Parsec
1112import Text.Parsec.String
1213import Text.Parsec.Expr
@@ -21,14 +22,16 @@ import Control.Monad.State
2122import System.Console.Haskeline
2223import System.IO
2324import System.Directory (getHomeDirectory)
25+import qualified Data.UUID as U
26+import Data.UUID.V4 (nextRandom)
2427
2528lexer :: Token.TokenParser ()
2629lexer = Token.makeTokenParser tutD
2730 where tutD = emptyDef {
2831 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
2932 Token.reservedNames = [],
30− Token.identStart = letter <|> char '_',
31− Token.identLetter = alphaNum <|> char '_'}
33+ Token.identStart = letter <|> char '_' <|> char '#',
34+ Token.identLetter = alphaNum <|> char '_' <|> char '#'}
3235
3336parens = Token.parens lexer
3437reservedOp = Token.reservedOp lexer
@@ -38,6 +41,13 @@ identifier = Token.identifier lexer
3841comma = Token.comma lexer
3942semi = Token.semi lexer
4043
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+
4151--used in projection
4252attributeList :: Parser [AttributeName]
4353attributeList = sepBy identifier comma
@@ -235,41 +245,89 @@ parseString str = case parse multipleDatabaseExpr "" str of
235245 Left err -> Left $ ParseError (show err)
236246 Right r -> Right r
237247
238−data TutorialDOperator where
239− ShowRelation :: RelationalExpr -> TutorialDOperator
240− ShowRelationType :: RelationalExpr -> TutorialDOperator
241− ShowConstraint :: String -> TutorialDOperator
242− Quit :: TutorialDOperator
248+--operators which only rely on database context reading
249+data ContextOperator where
250+ ShowRelation :: RelationalExpr -> ContextOperator
251+ ShowRelationType :: RelationalExpr -> ContextOperator
252+ ShowConstraint :: String -> ContextOperator
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
243263 deriving (Show)
244264
245−typeP :: Parser TutorialDOperator
265+typeP :: Parser ContextOperator
246266typeP = do
247− reservedOp ":t"
267+ reservedOp ":type"
248268 expr <- relExpr
249269 return $ ShowRelationType expr
250270
251−showRelP :: Parser TutorialDOperator
271+showRelP :: Parser ContextOperator
252272showRelP = do
253− reservedOp ":s"
273+ reservedOp ":show"
254274 expr <- relExpr
255275 return $ ShowRelation expr
256276
257−quitP :: Parser TutorialDOperator
277+quitP :: Parser ContextOperator
258278quitP = do
259− reservedOp ":q"
279+ reservedOp ":quit"
260280 return Quit
261281
262−showConstraintsP :: Parser TutorialDOperator
282+showConstraintsP :: Parser ContextOperator
263283showConstraintsP = do
264− reservedOp ":c"
284+ reservedOp ":constraints"
265285 constraintName <- option "" identifier
266286 return $ ShowConstraint constraintName
267287
268−interpreterOps :: Parser TutorialDOperator
269−interpreterOps = typeP
270− <|> showRelP
271− <|> showConstraintsP
272− <|> quitP
288+jumpToHeadP :: Parser GraphOperator
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
325+ <|> showRelP
326+ <|> showConstraintsP
327+ <|> quitP
328+
329+interpreterOps :: Parser (Either ContextOperator GraphOperator)
330+interpreterOps = liftM Left contextOps <|> liftM Right transactionGraphOps
273331
274332showRelationAttributes :: Relation -> String
275333showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
@@ -285,17 +343,17 @@ data TutorialDOperatorResult = QuitResult |
285343 DisplayErrorResult String |
286344 NoActionResult
287345
288−evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> TutorialDOperatorResult
289−evalTutorialDOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
346+evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult
347+evalContextOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
290348 (Right rel, _) -> DisplayResult $ showRelationAttributes rel
291349 (Left err, _) -> DisplayErrorResult $ show err
292350
293−evalTutorialDOp context (ShowRelation expr) = do
351+evalContextOp context (ShowRelation expr) = do
294352 case runState (evalRelationalExpr expr) context of
295353 (Left err, _) -> DisplayErrorResult $ show err
296354 (Right rel, _) -> DisplayResult $ showRelation rel
297355
298−evalTutorialDOp context (ShowConstraint name) = do
356+evalContextOp context (ShowConstraint name) = do
299357 DisplayResult $ show filteredDeps
300358 where
301359 deps = inclusionDependencies context
@@ -303,51 +361,114 @@ evalTutorialDOp context (ShowConstraint name) = do
303361 "" -> deps
304362 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
305363
306−evalTutorialDOp context (Quit) = QuitResult
307−
308−example1 = "relA {a,b, c}"
309−example2 = "relA join relB"
310−example3 = "relA join relB {x,y,z}"
311−example4 = "(relA) {x,y,z}"
312−example5 = "relA union relB"
313−example6 = "rv1 := true"
314−example7 = "rv1 := relA union relB"
315−example8 = "relA := true; relB := false"
316−example9 = "relA := relation { SNO CHAR }"
364+--I need to pass the transaction graph around instead of the singular context :/
365+evalContextOp context (Quit) = QuitResult
366+
367+-- returns the new "current" transaction, updated graph, and tutorial d result
368+-- the current transaction is not part of the transaction graph until it is committed
369+evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
370+
371+--affects only disconncted transaction
372+evalGraphOp newUUID trans graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
373+ Nothing -> Left $ NoSuchTransactionError jumpUUID
374+ Just parentTrans -> Right (newTrans, graph)
375+ where
376+ newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
317377
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+
318422interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
319423interpret context tutdstring = case parseString tutdstring of
320424 Left err -> (Just err, context)
321425 Right parsed -> runState (evalContextExpr parsed) context
322426
323427-- for interpreter-specific operations
324−interpretOps :: DatabaseContext -> String -> TutorialDOperatorResult
325−interpretOps context instring = case parse interpreterOps "" instring of
326− Left err -> NoActionResult
327− Right ops -> evalTutorialDOp context ops
428+interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
429+interpretOps newUUID trans@(DisconnectedTransaction parentUUID context) transGraph instring = case parse interpreterOps "" instring of
430+ Left err -> (trans, transGraph, NoActionResult)
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.")
328436
329−reprLoop :: DatabaseContext -> IO ()
330−reprLoop context = do
437+promptText :: DisconnectedTransaction -> TransactionGraph -> String
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
331448 homeDirectory <- getHomeDirectory
332− let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
333− maybeLine <- runInputT settings $ do
334− getInputLine "TutorialD: "
449+ let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
450+
451+ maybeLine <- runInputT settings $ getInputLine (promptText currentTransaction graph)
452+
453+ let roloop = reprLoop currentTransaction graph
335454 case maybeLine of
336455 Nothing -> return ()
337456 Just line -> do
338− case interpretOps context line of
339− QuitResult -> return ()
340− DisplayErrorResult err -> hPutStrLn stderr ("ERR: " ++ err) >> reprLoop context
341− DisplayResult out -> do
457+ newUUID <- nextRandom
458+ case interpretOps newUUID currentTransaction graph line of
459+ (_, _, QuitResult) -> return ()
460+ (_, _, DisplayErrorResult err) -> hPutStrLn stderr ("ERR: " ++ err) >> roloop
461+ (updatedTrans, updatedGraph, DisplayResult out) -> do
342462 putStrLn out
343− reprLoop context
344− NoActionResult -> do
345− let (value, contextup) = interpret context line
346− case value of
347− Nothing -> reprLoop contextup
348− (Just err) -> do
349− hPutStrLn stderr ("ERR:" ++ show err)
350− reprLoop context
463+ reprLoop updatedTrans updatedGraph
464+ (_, _, NoActionResult) -> do
465+ let (value, contextup) = interpret currentContext line
466+ let updatedTransaction = DisconnectedTransaction currentParentUUID contextup
467+ case value of
468+ Nothing -> reprLoop updatedTransaction graph
469+ Just err -> do
470+ hPutStrLn stderr ("ERR:" ++ show err)
471+ reprLoop currentTransaction graph
351472
352473restrictionPredicateP :: Parser RestrictionPredicateExpr
353474restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
@@ -382,4 +503,8 @@ stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
382503intAtomP = do
383504 intstr <- many digit
384505 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+