@@ -1,661 +1,83 @@
11{-# LANGUAGE GADTs,OverloadedStrings #-}
22module TutorialD.Interpreter where
3+import TutorialD.Interpreter.Base
4+import TutorialD.Interpreter.RODatabaseContextOperator
5+import TutorialD.Interpreter.DatabaseExpr
6+import TutorialD.Interpreter.TransactionGraphOperator
37import ProjectM36.Base
4−import ProjectM36.Relation
5−import ProjectM36.Tuple
6−import ProjectM36.TupleSet
7−import ProjectM36.Error
8−import qualified ProjectM36.Attribute as A
9−import ProjectM36.RelationalExpression
10−import ProjectM36.Relation.Show.Term
11−import ProjectM36.StaticOptimizer
128import ProjectM36.Transaction
13−import ProjectM36.Transaction.Show
14−import ProjectM36.Atom
159import Text.Parsec
1610import Text.Parsec.String
17−import Text.Parsec.Expr
18−import Text.Parsec.Language
19−import qualified Text.Parsec.Token as Token
20−import qualified Data.Set as S
21−import qualified Data.HashSet as HS
22−import qualified Data.Map as M
23−import qualified Data.List as L
24−import Control.Applicative (liftA, (<*), (*>), (<$>))
2511import Control.Monad.State
2612import System.Console.Haskeline
2713import System.IO
2814import System.Directory (getHomeDirectory)
2915import qualified Data.UUID as U
3016import Data.UUID.V4 (nextRandom)
31−import qualified Data.Vector as V
3217import qualified Data.Text as T
3318import qualified Data.Text.IO as TIO
19+import Control.Applicative ((<*))
3420
3521{-
36−List of Tutorial D operators:
37−show relation expression type :: relexpr -> context -> opresult
38−show relvar :: relvar name -> context -> opresult
39−quit :: ()
40−show graph :: graph -> DisconnectedTransaction -> opresult
41−show constraints :: context -> opresult
42−jump to head :: head name -> graph -> DisconnectedTransaction (graph unchanged)
43−jump to UUID :: uuid -> graph -> DisconnectedTransaction (graph unchanged)
44−branch :: uuid -> branch name -> graph -> (DisconnectedTransation, graph)
45−commit :: uuid -> DisconnectedTransaction -> graph -> (DisconnectedTransaction, graph)
46−rollback :: DisconnectedTransaction -> graph -> (DisconnectedTransaction, graph)
47−
48−
49−-}
50−lexer :: Token.TokenParser ()
51−lexer = Token.makeTokenParser tutD
52− where tutD = emptyDef {
53− Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
54− Token.reservedNames = [],
55− Token.identStart = letter <|> char '_',
56− Token.opLetter = oneOf ":!#$%&*+./<=>?\\^|-~", -- remove "@" so it can be used as attribute marker without spaces
57− Token.identLetter = alphaNum <|> char '_' <|> char '#'} -- # needed for Date examples
58−
59−parens = Token.parens lexer
60−reservedOp = Token.reservedOp lexer
61−reserved = Token.reserved lexer
62−braces = Token.braces lexer
63−identifier = Token.identifier lexer
64−comma = Token.comma lexer
65−semi = Token.semi lexer
66−
67−uuidP :: Parser U.UUID
68−uuidP = do
69− uuidStr <- many (alphaNum <|> char '-')
70− case U.fromString uuidStr of
71− Nothing -> fail "Invalid uuid string"
72− Just uuid -> return uuid
73−
74−--used in projection
75−attributeList :: Parser [AttributeName]
76−attributeList = do
77− attrs <- sepBy identifier comma
78− return $ map T.pack attrs
79−
80−makeRelation :: Parser RelationalExpr
81−makeRelation = do
82− reservedOp "relation"
83− attrs <- (try makeAttributes <|> return A.emptyAttributes)
84− if not (A.null attrs) then do
85− return $ MakeStaticRelation attrs emptyTupleSet
86− else do
87− tuples <- braces (sepBy tupleP comma)
88− return $ MakeStaticRelation (tupleAttributes (head tuples)) (HS.fromList tuples)
89−
90−--used in relation creation
91−makeAttributes :: Parser Attributes
92−makeAttributes = do
93− attrList <- braces (sepBy attributeAndType comma)
94− return $ A.attributesFromList attrList
95−
96−attributeAndType :: Parser Attribute
97−attributeAndType = do
98− attrName <- identifier
99− attrTypeName <- identifier
100− --convert type name into type
101− case tutDTypeToAtomType attrTypeName of
102− Just t -> return $ Attribute (T.pack attrName) t
103− Nothing -> fail (attrTypeName ++ " is not a valid type name.")
104−
105−tupleP :: Parser RelationTuple
106−tupleP = do
107− reservedOp "tuple"
108− attrAssocs <- braces (sepBy tupleAtomP comma)
109− let attrs = A.attributesFromList $ map (\(attrName, atom) -> Attribute attrName (atomTypeForAtom atom)) attrAssocs
110− let atoms = V.fromList $ map snd attrAssocs
111− return $ mkRelationTuple attrs atoms
112−
113−tupleAtomP :: Parser (AttributeName, Atom)
114−tupleAtomP = do
115− attributeName <- identifier
116− attrType <- identifier
117− atom <- parens (stringAtomP <|> intAtomP)
118− case tutDTypeToAtomType attrType of
119− Nothing -> fail (attrType ++ " is not a valid type name.")
120− Just typeA -> if typeA == atomTypeForAtom atom then
121− return $ (T.pack attributeName, atom)
122− else
123− fail "type mismatch in tuple generation"
124−
125−--convert Tutorial D type to AtomType
126−tutDTypeToAtomType :: String -> Maybe AtomType
127−tutDTypeToAtomType tutDType = case tutDType of
128− "char" -> Just StringAtomType
129− "int" -> Just IntAtomType
130− _ -> Nothing
131−
132−atomTypeToTutDType :: AtomType -> Maybe T.Text
133−atomTypeToTutDType atomType = case atomType of
134− StringAtomType -> Just "char"
135− IntAtomType -> Just "int"
136− RelationAtomType attrs -> Just $ "relation" `T.append` showRelationAttributes attrs
137− _ -> Nothing
138−
139−relVarP :: Parser RelationalExpr
140−relVarP = liftA (RelationVariable . T.pack) identifier
141−
142−relTerm = parens relExpr
143− <|> makeRelation
144− <|> relVarP
145−
146−projectOp = do
147− attrs <- braces attributeList
148− return $ Project (S.fromList attrs)
149−
150−assignP :: Parser DatabaseExpr
151−assignP = do
152− relVarName <- try $ do
153− relVarName <- identifier
154− reservedOp ":="
155− return relVarName
156− expr <- relExpr
157− return $ Assign (T.pack relVarName) expr
158−
159−renameClause = do
160− oldAttr <- identifier
161− reservedOp "as"
162− newAttr <- identifier
163− return $ (oldAttr, newAttr)
164−
165−renameP :: Parser (RelationalExpr -> RelationalExpr)
166−renameP = do
167− reservedOp "rename"
168− (oldAttr, newAttr) <- braces renameClause
169− return $ Rename (T.pack oldAttr) (T.pack newAttr)
170−
171−whereClauseP = do
172− reservedOp "where"
173− boolExpr <- restrictionPredicateP
174− return $ Restrict boolExpr
175−
176−groupClause = do
177− attrs <- braces attributeList
178− reservedOp "as"
179− newAttrName <- identifier
180− return $ (attrs, newAttrName)
181−
182−groupP :: Parser (RelationalExpr -> RelationalExpr)
183−groupP = do
184− reservedOp "group"
185− (groupAttrList, groupAttrName) <- parens groupClause
186− return $ Group (S.fromList groupAttrList) (T.pack groupAttrName)
187−
188−--in "Time and Relational Theory" (2014), Date's Tutorial D grammar for ungroup takes one attribute, while in previous books, it take multiple arguments. Let us assume that nested ungroups are the same as multiple attributes.
189−ungroupP :: Parser (RelationalExpr -> RelationalExpr)
190−ungroupP = do
191− reservedOp "ungroup"
192− rvaAttrName <- identifier
193− return $ Ungroup (T.pack rvaAttrName)
194−
195−extendP :: Parser (RelationalExpr -> RelationalExpr)
196−extendP = do
197− reservedOp ":"
198− tupleExpr <- braces tupleExpressionP
199− return $ Extend tupleExpr
200−
201−{-
202−rewrite summarize as extend as evaluate
203−
204−summarize SP per (SP{SNO}) add (sum(@QTY) as SUMQ) === ((SP rename {QTY as _}) group ({_} as x)) : {QTY:=sum(@x)}{S#,QTY}
205−so, in general,
206−summarize rX per (relExpr) add (func(@attr) as funcd) === ((rX rename {attr as _}) group ({_} as _)) : {QTY:=sum(@_)}{relExpr, _}
207−-}
208−{-
209−summarizeP :: Parser (RelationalExpr -> RelationalExpr)
210−summarizeP = do
211− reservedOp "per"
212− -- "summarize in Tutorial D requires the heading of the per relation to be a subset of that of the relation to be summarized"
213− perExpr <- parens relExpr
214− reservedOp "add"
215− (funcAtomExpr, newAttrName) <- parens summaryP
216− --rewrite summarize as extend
217− --return $ Summarize funcAtomExpr newAttrName perExpr
218−
219−summaryP :: Parser (AtomExpr, AttributeName)
220−summaryP = do
221− expr <- atomExprP
222− reserved "as"
223− attrName <- identifier
224− return (expr, T.pack attrName)
225−-}
226−
227−relOperators = [
228− [Postfix projectOp],
229− [Postfix renameP],
230− [Postfix whereClauseP],
231− [Postfix groupP],
232− [Postfix ungroupP],
233− [Infix (reservedOp "join" >> return Join) AssocLeft],
234− [Infix (reservedOp "union" >> return Union) AssocLeft],
235− [Infix (reservedOp "=" >> return Equals) AssocNone],
236− [Postfix extendP]
237− ]
238−
239−relExpr :: Parser RelationalExpr
240−relExpr = buildExpressionParser relOperators relTerm
241−
242−databaseExpr :: Parser DatabaseExpr
243−databaseExpr = insertP
244− <|> deleteP
245− <|> updateP
246− <|> constraintP
247− <|> defineP
248− <|> undefineP
249− <|> assignP
250−
251−multipleDatabaseExpr :: Parser DatabaseExpr
252−multipleDatabaseExpr = do
253− exprs <- sepBy1 databaseExpr semi
254− return $ MultipleExpr exprs
255−
256−insertP :: Parser DatabaseExpr
257−insertP = do
258− reservedOp "insert"
259− relvar <- identifier
260− expr <- relExpr
261− return $ Insert (T.pack relvar) expr
262−
263−defineP :: Parser DatabaseExpr
264−defineP = do
265− relVarName <- try $ do
266− relVarName <- identifier
267− reservedOp "::"
268− return relVarName
269− attributeSet <- makeAttributes
270− return $ Define (T.pack relVarName) attributeSet
271−
272−undefineP :: Parser DatabaseExpr
273−undefineP = do
274− reservedOp "undefine"
275− relVarName <- identifier
276− return $ Undefine (T.pack relVarName)
277−
278−deleteP :: Parser DatabaseExpr
279−deleteP = do
280− reservedOp "delete"
281− relVarName <- identifier
282− predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
283− return $ Delete (T.pack relVarName) predicate
284−
285−updateP :: Parser DatabaseExpr
286−updateP = do
287− reservedOp "update"
288− relVarName <- identifier
289− predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
290− attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
291− return $ Update (T.pack relVarName) (M.mapKeys T.pack $ attributeAssignments) predicate
292−
293−constraintP :: Parser DatabaseExpr
294−constraintP = do
295− reservedOp "constraint"
296− constraintName <- identifier
297− subset <- relExpr
298− reservedOp "in"
299− superset <- relExpr
300− return $ AddInclusionDependency (InclusionDependency (T.pack constraintName) subset superset)
301−
302−attributeAssignment :: Parser (String, Atom)
303−attributeAssignment = do
304− attrName <- identifier
305− reservedOp ":="
306− atom <- stringAtomP <|> intAtomP
307− return $ (attrName, atom)
308−
309−parseString :: String -> Either RelationalError DatabaseExpr
310−parseString str = case parse (multipleDatabaseExpr <* eof) "" str of
311− Left err -> Left $ ParseError (T.pack (show err))
312− Right r -> Right r
313−
314−--operators which only rely on database context reading
315−data ContextOperator where
316− ShowRelation :: RelationalExpr -> ContextOperator
317− ShowRelationType :: RelationalExpr -> ContextOperator
318− ShowConstraint :: StringType -> ContextOperator
319− ShowPlan :: DatabaseExpr -> ContextOperator
320− Quit :: ContextOperator
321− deriving (Show)
322−
323−--operators which manipulate a transaction graph
324−data GraphOperator where
325− JumpToHead :: HeadName -> GraphOperator
326− JumpToTransaction :: U.UUID -> GraphOperator
327− Branch :: HeadName -> GraphOperator
328− Commit :: GraphOperator
329− Rollback :: GraphOperator
330− ShowGraph :: GraphOperator
331−
332−typeP :: Parser ContextOperator
333−typeP = do
334− reservedOp ":type"
335− expr <- relExpr
336− return $ ShowRelationType expr
337−
338−showRelP :: Parser ContextOperator
339−showRelP = do
340− reservedOp ":showexpr"
341− expr <- relExpr
342− return $ ShowRelation expr
343−
344−showPlanP :: Parser ContextOperator
345−showPlanP = do
346− reservedOp ":showplan"
347− expr <- databaseExpr
348− return $ ShowPlan expr
349−
350−quitP :: Parser ContextOperator
351−quitP = do
352− reservedOp ":quit"
353− return Quit
354−
355−showConstraintsP :: Parser ContextOperator
356−showConstraintsP = do
357− reservedOp ":constraints"
358− constraintName <- option "" identifier
359− return $ ShowConstraint (T.pack constraintName)
360−
361−jumpToHeadP :: Parser GraphOperator
362−jumpToHeadP = do
363− reservedOp ":jumphead"
364− headid <- identifier
365− return $ JumpToHead (T.pack headid)
366−
367−jumpToTransactionP :: Parser GraphOperator
368−jumpToTransactionP = do
369− reservedOp ":jump"
370− uuid <- uuidP
371− return $ JumpToTransaction uuid
372−
373−branchTransactionP :: Parser GraphOperator
374−branchTransactionP = do
375− reservedOp ":branch"
376− branchName <- identifier
377− return $ Branch (T.pack branchName)
378−
379−commitTransactionP :: Parser GraphOperator
380−commitTransactionP = do
381− reservedOp ":commit"
382− return $ Commit
383−
384−rollbackTransactionP :: Parser GraphOperator
385−rollbackTransactionP = do
386− reservedOp ":rollback"
387− return $ Rollback
388−
389−showGraphP :: Parser GraphOperator
390−showGraphP = do
391− reservedOp ":showgraph"
392− return $ ShowGraph
393−
394−transactionGraphOps :: Parser GraphOperator
395−transactionGraphOps = do
396− jumpToHeadP
397− <|> jumpToTransactionP
398− <|> branchTransactionP
399− <|> commitTransactionP
400− <|> rollbackTransactionP
401− <|> showGraphP
402−
403−contextOps :: Parser ContextOperator
404−contextOps = typeP
405− <|> showRelP
406− <|> showConstraintsP
407− <|> showPlanP
408− <|> quitP
409−
410−interpreterOps :: Parser (Either ContextOperator GraphOperator)
411−interpreterOps = liftM Left contextOps <|> liftM Right transactionGraphOps
412−
413−showRelationAttributes :: Attributes -> T.Text
414−showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrsL) `T.append` "}"
415− where
416− showAttribute (Attribute name atomType) = name `T.append` " " `T.append` case atomTypeToTutDType atomType of
417− Just t -> t
418− Nothing -> "unknown"
419− attrsL = V.toList attrs
420−
421−data TutorialDOperatorResult = QuitResult |
422− DisplayResult StringType |
423− DisplayErrorResult StringType |
424− QuietSuccessResult |
425− NoActionResult --refactor to make this dead- there should be only one parser
426−
427−evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult
428−evalContextOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
429− (Right rel, _) -> DisplayResult $ showRelationAttributes (attributes rel)
430− (Left err, _) -> DisplayErrorResult $ T.pack (show err)
431−
432−evalContextOp context (ShowRelation expr) = do
433− case runState (evalRelationalExpr expr) context of
434− (Left err, _) -> DisplayErrorResult $ T.pack (show err)
435− (Right rel, _) -> DisplayResult $ showRelation rel
436−
437−evalContextOp context (ShowConstraint name) = do
438− DisplayResult $ T.pack (show filteredDeps)
439− where
440− deps = inclusionDependencies context
441− filteredDeps = case name of
442− "" -> deps
443− name2 -> HS.filter (\(InclusionDependency n _ _) -> n == name2) deps
444−
445−evalContextOp context (ShowPlan dbExpr) = do
446− DisplayResult $ T.pack (show plan)
447− where
448− plan = evalState (applyStaticDatabaseOptimization dbExpr) context
449−
450−evalContextOp _ (Quit) = QuitResult
451−
452−-- returns the new "current" transaction, updated graph, and tutorial d result
453−-- the current transaction is not part of the transaction graph until it is committed
454−evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
455−
456−--affects only disconncted transaction
457−evalGraphOp _ _ graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
458− Left err -> Left err
459− Right parentTrans -> Right (newTrans, graph, QuietSuccessResult)
460− where
461− newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
462−
463−-- switch from one head to another
464−-- affects only disconnectedtransaction
465−evalGraphOp _ _ graph (JumpToHead headName) =
466− case transactionForHead headName graph of
467− Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in
468− Right (disconnectedTrans, graph, QuietSuccessResult)
469− Nothing -> Left $ NoSuchHeadNameError headName
470−-- add new head pointing to branchPoint
471−-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
472−-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
473− {-
474−evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
475− Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
476− Just parentTrans -> case addBranch newBranchName parentTrans graph of
477− Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
478− Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
479− where
480− newDiscon = DisconnectedTransaction (transactionUUID parentTrans) disconContext
22+context ops are read-only operations which only operate on the database context (relvars and constraints)
23+database ops are read-write operations which change the database context (such as relvar assignment)
24+graph ops are read-write operations which change the transaction graph
48125-}
482−
483−-- create a new commit and add it to the heads
484−-- 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)
485−evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
486− Left err -> Left err
487− Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
488− Left err -> Left err
489− Right (_, newGraph) -> Right (newDiscon, newGraph, QuietSuccessResult)
490− where
491− newDiscon = DisconnectedTransaction newUUID disconContext
26+data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
27+ DatabaseExprOp DatabaseExpr |
28+ GraphOp TransactionGraphOperator
49229
493−-- add the disconnected transaction to the graph
494−-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
495−evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of
496− Left err -> Left err
497− Right parentTransaction -> case headNameForTransaction parentTransaction graph of
498− Nothing -> Left $ TransactionIsNotAHeadError parentUUID
499− Just headName -> case maybeUpdatedGraph of
500− Left err-> Left err
501− Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph, QuietSuccessResult)
502− where
503− newDisconnectedTrans = newDisconnectedTransaction newTransUUID context
504− maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph
505−
506−-- refresh the disconnected transaction, return the same graph
507−evalGraphOp _ (DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of
508− Left err -> Left err
509− Right parentTransaction -> Right (newDiscon, graph, QuietSuccessResult)
510− where
511− newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)
512−
513−--display transaction graph as relation
514−evalGraphOp _ discon graph ShowGraph = do
515− graphStr <- graphAsRelation discon graph
516− return (discon, graph, DisplayResult $ showRelation graphStr)
517−
518−--shouldn't this be Either RelationalError DatabaseContext?
519−interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
520−interpret context tutdstring = case parseString tutdstring of
521− Left err -> (Just err, context)
522− Right parsed -> runState (evaluator parsed) context
523− where
524− evaluator expr = do
525− optExpr <- applyStaticDatabaseOptimization expr
526− --case optExpr of
527− case optExpr of
528− Left err -> return $ Just err
529− Right optExprA -> evalContextExpr optExprA
30+interpreterParserP :: Parser ParsedOperation
31+interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
32+ liftM GraphOp (transactionGraphOpP <* eof) <|>
33+ liftM DatabaseExprOp (databaseExprOpP <* eof)
53034
531−--no optimization
532−interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
533−interpretNO context tutdstring = case parseString tutdstring of
534− Left err -> (Just err, context)
535− Right parsed -> runState (evalContextExpr parsed) context
536−
537−-- for interpreter-specific operations
538−interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
539−interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
540− Left _ -> (trans, transGraph, NoActionResult)
541− Right ops -> case ops of
542− Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
543− Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
544− Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
545− Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
546−
54735promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
54836promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
54937 where
550− transInfo = case transactionForUUID parentUUID graph of
38+ transInfo = case transactionForUUID parentUUID graph of
55139 Left _ -> "unknown"
55240 Right parentTrans -> case headNameForTransaction parentTrans graph of
55341 Nothing -> T.pack (show $ transactionUUID parentTrans)
55442 Just headName -> headName
555−
43+
44+interpret :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (TutorialDOperatorResult, DisconnectedTransaction, TransactionGraph)
45+interpret freshUUID discon@(DisconnectedTransaction parentUUID context) graph inputString = case parse interpreterParserP "" inputString of
46+ Left err -> (DisplayErrorResult (T.pack $ show err), discon, graph)
47+ Right (RODatabaseContextOp execOp) -> (evalRODatabaseContextOp context execOp, discon, graph)
48+ Right (DatabaseExprOp execOp) -> case evalDatabaseExpr True context execOp of
49+ Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph)
50+ Right context' -> (QuietSuccessResult, DisconnectedTransaction parentUUID context', graph)
51+ Right (GraphOp execOp) -> case evalGraphOp freshUUID discon graph execOp of
52+ Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph)
53+ Right (discon', graph', result') -> (result', discon', graph')
54+
55+
56+
55657reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()
557−reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentContext) graph = do
58+reprLoop currentTransaction graph = do
55859 homeDirectory <- getHomeDirectory
55960 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
560−
61+
56162 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText currentTransaction graph))
56263
56364 let roloop = reprLoop currentTransaction graph
56465 case maybeLine of
56566 Nothing -> return ()
566− Just line -> do
67+ Just line -> do
56768 newUUID <- nextRandom
568− case interpretOps newUUID currentTransaction graph line of
569− (_, _, QuitResult) -> return ()
570− (_, _, DisplayErrorResult err) -> TIO.hPutStrLn stderr ("ERR: " `T.append` err) >> roloop
571− (updatedTrans, updatedGraph, DisplayResult out) -> do
69+ case interpret newUUID currentTransaction graph line of
70+ (QuitResult, _, _) -> return ()
71+ (DisplayErrorResult err, _, _) -> TIO.hPutStrLn stderr ("ERR: " `T.append` err) >> roloop
72+ (DisplayResult out, updatedTrans, updatedGraph) -> do
57273 TIO.putStrLn out
57374 reprLoop updatedTrans updatedGraph
574− (updatedTrans, updatedGraph, QuietSuccessResult) -> do
75+ (QuietSuccessResult, updatedTrans, updatedGraph) -> do
57576 TIO.putStrLn "Done."
57677 reprLoop updatedTrans updatedGraph
577− (_, _, NoActionResult) -> do
578− let (value, contextup) = interpret currentContext line
579− let updatedTransaction = DisconnectedTransaction currentParentUUID contextup
580− case value of
581− Nothing -> reprLoop updatedTransaction graph
582− Just err -> do
583− TIO.hPutStrLn stderr ("ERR:" `T.append` T.pack (show err))
584− reprLoop currentTransaction graph
585−
586−restrictionPredicateP :: Parser RestrictionPredicateExpr
587−restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
588− where
589− predicateOperators = [
590− [Prefix (reservedOp "not" >> return NotPredicate)],
591− [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
592− [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
593− ]
594− predicateTerm = parens restrictionPredicateP
595− <|> try restrictionAttributeEqualityP
596− <|> try relationalBooleanExpr
597−
598−
599−relationalBooleanExpr :: Parser RestrictionPredicateExpr
600−relationalBooleanExpr = do
601− relexpr <- relExpr
602− return $ RelationalExprPredicate relexpr
603−
604−restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
605−restrictionAttributeEqualityP = do
606− attributeName <- identifier
607− reservedOp "="
608− atomexpr <- atomExprP
609− return $ AttributeEqualityPredicate (T.pack attributeName) atomexpr
610−
611−quotedChar = noneOf "\""
612− <|> try (string "\"\"" >> return '"')
613−
614−stringAtomP = liftA (StringAtom . T.pack) (string "\"" *> many quotedChar <* string "\"")
61578
616−intAtomP = do
617− intstr <- many1 digit
618− return $ IntAtom (read intstr)
619−
62079--used by :dumpGraph
62180{-
62281displayTransactionGraph :: TransactionGraph -> String
62382displayTransactionGraph (TransactionGraph _ transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet
624−-}
625−
626−multiTupleExpressionP :: Parser [TupleExpr]
627−multiTupleExpressionP = sepBy tupleExpressionP comma
628−
629−tupleExpressionP :: Parser TupleExpr
630−tupleExpressionP = attributeTupleExpressionP
631−
632−attributeTupleExpressionP :: Parser TupleExpr
633−attributeTupleExpressionP = do
634− newAttr <- identifier
635− reservedOp ":="
636− atom <- atomExprP
637− return $ AttributeTupleExpr (T.pack newAttr) atom
638−
639−atomExprP :: Parser AtomExpr
640−atomExprP = try functionAtomExprP <|>
641− attributeAtomExprP <|>
642− nakedAtomExprP <|>
643− relationalAtomExprP
644−
645−attributeAtomExprP :: Parser AtomExpr
646−attributeAtomExprP = do
647− _ <- string "@"
648− attrName <- identifier
649− return $ AttributeAtomExpr (T.pack attrName)
650−
651−nakedAtomExprP :: Parser AtomExpr
652−nakedAtomExprP = NakedAtomExpr <$> (stringAtomP <|> intAtomP)
653−
654−functionAtomExprP :: Parser AtomExpr
655−functionAtomExprP = do
656− funcName <- identifier
657− argList <- parens (sepBy atomExprP comma)
658− return $ FunctionAtomExpr (T.pack funcName) argList
659−
660−relationalAtomExprP :: Parser AtomExpr
661−relationalAtomExprP = RelationAtomExpr <$> relExpr
83+-}