git.iko.soy/project-m36
on master help sign in
refactor TutorialD parsers
177eccaAgentM
ProjectM36/TupleSet.hs+3−4
compare with master
unifiedsplit
@@ -3,7 +3,6 @@ import ProjectM36.Base
3import ProjectM36.Tuple
3import ProjectM36.Tuple
4import ProjectM36.Error
4import ProjectM36.Error
5import qualified Data.HashSet as HS
5import qualified Data.HashSet as HS
6−--import Control.Monad (forM)
7import qualified Data.Vector as V
6import qualified Data.Vector as V
8import qualified Control.Parallel.Strategies as P
7import qualified Control.Parallel.Strategies as P
9import Data.Either
8import Data.Either
@@ -20,7 +19,7 @@ verifyTupleSet :: Attributes -> RelationTupleSet -> Either RelationalError Relat
20verifyTupleSet attrs tupleSet = do
19verifyTupleSet attrs tupleSet = do
21 --check that all tuples have the same attributes and that the atom types match
20 --check that all tuples have the same attributes and that the atom types match
22 let tupleList = (map (verifyTuple attrs) (HS.toList tupleSet)) `P.using` P.parListChunk chunkSize P.r0
21 let tupleList = (map (verifyTuple attrs) (HS.toList tupleSet)) `P.using` P.parListChunk chunkSize P.r0
23− chunkSize = HS.size tupleSet `div` 24
22+ chunkSize = HS.size tupleSet `div` 24
24 --let tupleList = P.parMap P.rdeepseq (verifyTuple attrs) (HS.toList tupleSet)
23 --let tupleList = P.parMap P.rdeepseq (verifyTuple attrs) (HS.toList tupleSet)
25 if length (lefts tupleList) > 0 then
24 if length (lefts tupleList) > 0 then
26 Left $ head (lefts tupleList)
25 Left $ head (lefts tupleList)
@@ -29,10 +28,10 @@ verifyTupleSet attrs tupleSet = do
29
28
30mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTupleSet
29mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTupleSet
31mkTupleSet attrs tuples = verifyTupleSet attrs tupSet
30mkTupleSet attrs tuples = verifyTupleSet attrs tupSet
32− where
31+ where
33 tupSet = HS.fromList tuples
32 tupSet = HS.fromList tuples
34
33
35mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet
34mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet
36mkTupleSetFromList attrs atomMatrix = verifyTupleSet attrs tupSet
35mkTupleSetFromList attrs atomMatrix = verifyTupleSet attrs tupSet
37 where
36 where
38− tupSet = HS.fromList $ map (\atomList -> mkRelationTuple attrs (V.fromList atomList)) atomMatrix
37+ tupSet = HS.fromList $ map (\atomList -> mkRelationTuple attrs (V.fromList atomList)) atomMatrix
TutorialD/Interpreter.hs+39−617
@@ -1,661 +1,83 @@
1{-# LANGUAGE GADTs,OverloadedStrings #-}
1{-# LANGUAGE GADTs,OverloadedStrings #-}
2module TutorialD.Interpreter where
2module TutorialD.Interpreter where
3+import TutorialD.Interpreter.Base
4+import TutorialD.Interpreter.RODatabaseContextOperator
5+import TutorialD.Interpreter.DatabaseExpr
6+import TutorialD.Interpreter.TransactionGraphOperator
3import ProjectM36.Base
7import 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
12import ProjectM36.Transaction
8import ProjectM36.Transaction
13−import ProjectM36.Transaction.Show
14−import ProjectM36.Atom
15import Text.Parsec
9import Text.Parsec
16import Text.Parsec.String
10import 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, (<*), (*>), (<$>))
25import Control.Monad.State
11import Control.Monad.State
26import System.Console.Haskeline
12import System.Console.Haskeline
27import System.IO
13import System.IO
28import System.Directory (getHomeDirectory)
14import System.Directory (getHomeDirectory)
29import qualified Data.UUID as U
15import qualified Data.UUID as U
30import Data.UUID.V4 (nextRandom)
16import Data.UUID.V4 (nextRandom)
31−import qualified Data.Vector as V
32import qualified Data.Text as T
17import qualified Data.Text as T
33import qualified Data.Text.IO as TIO
18import qualified Data.Text.IO as TIO
19+import Control.Applicative ((<*))
34
20
35{-
21{-
36−List of Tutorial D operators:
22+context ops are read-only operations which only operate on the database context (relvars and constraints)
37−show relation expression type :: relexpr -> context -> opresult
23+database ops are read-write operations which change the database context (such as relvar assignment)
38−show relvar :: relvar name -> context -> opresult
24+graph ops are read-write operations which change the transaction graph
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
481-}
25-}
482−
26+data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
483−-- create a new commit and add it to the heads
27+ DatabaseExprOp DatabaseExpr |
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)
28+ GraphOp TransactionGraphOperator
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
492
29
493−-- add the disconnected transaction to the graph
30+interpreterParserP :: Parser ParsedOperation
494−-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
31+interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
495−evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of
32+ liftM GraphOp (transactionGraphOpP <* eof) <|>
496− Left err -> Left err
33+ liftM DatabaseExprOp (databaseExprOpP <* eof)
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
530
34
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−
547promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
35promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
548promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
36promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
549 where
37 where
550− transInfo = case transactionForUUID parentUUID graph of
38+ transInfo = case transactionForUUID parentUUID graph of
551 Left _ -> "unknown"
39 Left _ -> "unknown"
552 Right parentTrans -> case headNameForTransaction parentTrans graph of
40 Right parentTrans -> case headNameForTransaction parentTrans graph of
553 Nothing -> T.pack (show $ transactionUUID parentTrans)
41 Nothing -> T.pack (show $ transactionUUID parentTrans)
554 Just headName -> headName
42 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+
556reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()
57reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()
557−reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentContext) graph = do
58+reprLoop currentTransaction graph = do
558 homeDirectory <- getHomeDirectory
59 homeDirectory <- getHomeDirectory
559 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
60 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
560−
61+
561 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText currentTransaction graph))
62 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText currentTransaction graph))
562
63
563 let roloop = reprLoop currentTransaction graph
64 let roloop = reprLoop currentTransaction graph
564 case maybeLine of
65 case maybeLine of
565 Nothing -> return ()
66 Nothing -> return ()
566− Just line -> do
67+ Just line -> do
567 newUUID <- nextRandom
68 newUUID <- nextRandom
568− case interpretOps newUUID currentTransaction graph line of
69+ case interpret newUUID currentTransaction graph line of
569− (_, _, QuitResult) -> return ()
70+ (QuitResult, _, _) -> return ()
570− (_, _, DisplayErrorResult err) -> TIO.hPutStrLn stderr ("ERR: " `T.append` err) >> roloop
71+ (DisplayErrorResult err, _, _) -> TIO.hPutStrLn stderr ("ERR: " `T.append` err) >> roloop
571− (updatedTrans, updatedGraph, DisplayResult out) -> do
72+ (DisplayResult out, updatedTrans, updatedGraph) -> do
572 TIO.putStrLn out
73 TIO.putStrLn out
573 reprLoop updatedTrans updatedGraph
74 reprLoop updatedTrans updatedGraph
574− (updatedTrans, updatedGraph, QuietSuccessResult) -> do
75+ (QuietSuccessResult, updatedTrans, updatedGraph) -> do
575 TIO.putStrLn "Done."
76 TIO.putStrLn "Done."
576 reprLoop updatedTrans updatedGraph
77 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 "\"")
615
78
616−intAtomP = do
617− intstr <- many1 digit
618− return $ IntAtom (read intstr)
619−
620--used by :dumpGraph
79--used by :dumpGraph
621{-
80{-
622displayTransactionGraph :: TransactionGraph -> String
81displayTransactionGraph :: TransactionGraph -> String
623displayTransactionGraph (TransactionGraph _ transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet
82displayTransactionGraph (TransactionGraph _ transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet
624−-}
83+-}
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
TutorialD/Interpreter/Base.hsnew file+53
@@ -0,0 +1,53 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module TutorialD.Interpreter.Base where
3+import Text.Parsec
4+import qualified Text.Parsec.Token as Token
5+import Text.Parsec.Language
6+import ProjectM36.Base
7+import qualified Data.Text as T
8+import qualified Data.List as L
9+import qualified Data.Vector as V
10+
11+lexer :: Token.TokenParser ()
12+lexer = Token.makeTokenParser tutD
13+ where tutD = emptyDef {
14+ Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
15+ Token.reservedNames = [],
16+ Token.identStart = letter <|> char '_',
17+ Token.opLetter = oneOf ":!#$%&*+./<=>?\\^|-~", -- remove "@" so it can be used as attribute marker without spaces
18+ Token.identLetter = alphaNum <|> char '_' <|> char '#'} -- # needed for Date examples
19+
20+parens = Token.parens lexer
21+reservedOp = Token.reservedOp lexer
22+reserved = Token.reserved lexer
23+braces = Token.braces lexer
24+identifier = Token.identifier lexer
25+comma = Token.comma lexer
26+semi = Token.semi lexer
27+
28+--convert Tutorial D type to AtomType
29+tutDTypeToAtomType :: String -> Maybe AtomType
30+tutDTypeToAtomType tutDType = case tutDType of
31+ "char" -> Just StringAtomType
32+ "int" -> Just IntAtomType
33+ _ -> Nothing
34+
35+atomTypeToTutDType :: AtomType -> Maybe T.Text
36+atomTypeToTutDType atomType = case atomType of
37+ StringAtomType -> Just "char"
38+ IntAtomType -> Just "int"
39+ RelationAtomType attrs -> Just $ "relation" `T.append` showRelationAttributes attrs
40+ _ -> Nothing
41+
42+showRelationAttributes :: Attributes -> T.Text
43+showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrsL) `T.append` "}"
44+ where
45+ showAttribute (Attribute name atomType) = name `T.append` " " `T.append` case atomTypeToTutDType atomType of
46+ Just t -> t
47+ Nothing -> "unknown"
48+ attrsL = V.toList attrs
49+
50+data TutorialDOperatorResult = QuitResult |
51+ DisplayResult StringType |
52+ DisplayErrorResult StringType |
53+ QuietSuccessResult
TutorialD/Interpreter/DatabaseExpr.hsnew file+114
@@ -0,0 +1,114 @@
1+module TutorialD.Interpreter.DatabaseExpr where
2+import Text.Parsec
3+import Text.Parsec.String
4+import ProjectM36.Base
5+import TutorialD.Interpreter.Base
6+import qualified Data.Text as T
7+import Control.Applicative ((<*), (*>))
8+import TutorialD.Interpreter.RelationalExpr
9+import qualified Data.Map as M
10+import Control.Monad.State
11+import ProjectM36.StaticOptimizer
12+import ProjectM36.Error
13+import ProjectM36.RelationalExpression
14+
15+--parsers which create "database expressions" which modify the database context (such as relvar assignment)
16+databaseExprP :: Parser DatabaseExpr
17+databaseExprP = insertP
18+ <|> deleteP
19+ <|> updateP
20+ <|> constraintP
21+ <|> defineP
22+ <|> undefineP
23+ <|> assignP
24+
25+assignP :: Parser DatabaseExpr
26+assignP = do
27+ relVarName <- try $ do
28+ relVarName <- identifier
29+ reservedOp ":="
30+ return relVarName
31+ expr <- relExprP
32+ return $ Assign (T.pack relVarName) expr
33+
34+multipleDatabaseExprP :: Parser DatabaseExpr
35+multipleDatabaseExprP = do
36+ exprs <- sepBy1 databaseExprP semi
37+ return $ MultipleExpr exprs
38+
39+insertP :: Parser DatabaseExpr
40+insertP = do
41+ reservedOp "insert"
42+ relvar <- identifier
43+ expr <- relExprP
44+ return $ Insert (T.pack relvar) expr
45+
46+defineP :: Parser DatabaseExpr
47+defineP = do
48+ relVarName <- try $ do
49+ relVarName <- identifier
50+ reservedOp "::"
51+ return relVarName
52+ attributeSet <- makeAttributesP
53+ return $ Define (T.pack relVarName) attributeSet
54+
55+undefineP :: Parser DatabaseExpr
56+undefineP = do
57+ reservedOp "undefine"
58+ relVarName <- identifier
59+ return $ Undefine (T.pack relVarName)
60+
61+deleteP :: Parser DatabaseExpr
62+deleteP = do
63+ reservedOp "delete"
64+ relVarName <- identifier
65+ predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
66+ return $ Delete (T.pack relVarName) predicate
67+
68+updateP :: Parser DatabaseExpr
69+updateP = do
70+ reservedOp "update"
71+ relVarName <- identifier
72+ predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
73+ attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignmentP comma)
74+ return $ Update (T.pack relVarName) (M.mapKeys T.pack $ attributeAssignments) predicate
75+
76+constraintP :: Parser DatabaseExpr
77+constraintP = do
78+ reservedOp "constraint"
79+ constraintName <- identifier
80+ subset <- relExprP
81+ reservedOp "in"
82+ superset <- relExprP
83+ return $ AddInclusionDependency (InclusionDependency (T.pack constraintName) subset superset)
84+
85+attributeAssignmentP :: Parser (String, Atom)
86+attributeAssignmentP = do
87+ attrName <- identifier
88+ reservedOp ":="
89+ atom <- stringAtomP <|> intAtomP
90+ return $ (attrName, atom)
91+
92+databaseExprOpP :: Parser DatabaseExpr
93+databaseExprOpP = multipleDatabaseExprP
94+
95+evalDatabaseExpr :: Bool -> DatabaseContext -> DatabaseExpr -> Either RelationalError DatabaseContext
96+evalDatabaseExpr useOptimizer context expr = do
97+ optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context
98+ case runState (evalContextExpr (if useOptimizer then optimizedExpr else expr)) context of
99+ (Nothing, context') -> Right context'
100+ (Just err, _) -> Left err
101+
102+
103+interpretDatabaseExpr :: DatabaseContext -> String -> Either RelationalError DatabaseContext
104+interpretDatabaseExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
105+ Left err -> Left $ ParseError (T.pack (show err))
106+ Right parsed -> evalDatabaseExpr True context parsed
107+
108+{-
109+--no optimization
110+interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
111+interpretNO context tutdstring = case parseString tutdstring of
112+ Left err -> (Just err, context)
113+ Right parsed -> runState (evalContextExpr parsed) context
114+-}
TutorialD/Interpreter/RODatabaseContextOperator.hsnew file+85
@@ -0,0 +1,85 @@
1+{-# LANGUAGE GADTs,OverloadedStrings #-}
2+module TutorialD.Interpreter.RODatabaseContextOperator where
3+import ProjectM36.Base
4+import ProjectM36.Relation
5+import ProjectM36.RelationalExpression
6+import ProjectM36.StaticOptimizer
7+import Text.Parsec
8+import Text.Parsec.String
9+import TutorialD.Interpreter.Base
10+import TutorialD.Interpreter.RelationalExpr
11+import TutorialD.Interpreter.DatabaseExpr
12+import Control.Monad.State
13+import qualified Data.Text as T
14+import qualified Data.HashSet as HS
15+import ProjectM36.Relation.Show.Term
16+
17+--operators which only rely on database context reading
18+data RODatabaseContextOperator where
19+ ShowRelation :: RelationalExpr -> RODatabaseContextOperator
20+ ShowRelationType :: RelationalExpr -> RODatabaseContextOperator
21+ ShowConstraint :: StringType -> RODatabaseContextOperator
22+ ShowPlan :: DatabaseExpr -> RODatabaseContextOperator
23+ Quit :: RODatabaseContextOperator
24+ deriving (Show)
25+
26+typeP :: Parser RODatabaseContextOperator
27+typeP = do
28+ reservedOp ":type"
29+ expr <- relExprP
30+ return $ ShowRelationType expr
31+
32+showRelP :: Parser RODatabaseContextOperator
33+showRelP = do
34+ reservedOp ":showexpr"
35+ expr <- relExprP
36+ return $ ShowRelation expr
37+
38+showPlanP :: Parser RODatabaseContextOperator
39+showPlanP = do
40+ reservedOp ":showplan"
41+ expr <- databaseExprP
42+ return $ ShowPlan expr
43+
44+quitP :: Parser RODatabaseContextOperator
45+quitP = do
46+ reservedOp ":quit"
47+ return Quit
48+
49+showConstraintsP :: Parser RODatabaseContextOperator
50+showConstraintsP = do
51+ reservedOp ":constraints"
52+ constraintName <- option "" identifier
53+ return $ ShowConstraint (T.pack constraintName)
54+
55+roDatabaseContextOperatorP :: Parser RODatabaseContextOperator
56+roDatabaseContextOperatorP = typeP
57+ <|> showRelP
58+ <|> showConstraintsP
59+ <|> showPlanP
60+ <|> quitP
61+
62+evalRODatabaseContextOp :: DatabaseContext -> RODatabaseContextOperator -> TutorialDOperatorResult
63+evalRODatabaseContextOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
64+ (Right rel, _) -> DisplayResult $ showRelationAttributes (attributes rel)
65+ (Left err, _) -> DisplayErrorResult $ T.pack (show err)
66+
67+evalRODatabaseContextOp context (ShowRelation expr) = do
68+ case runState (evalRelationalExpr expr) context of
69+ (Left err, _) -> DisplayErrorResult $ T.pack (show err)
70+ (Right rel, _) -> DisplayResult $ showRelation rel
71+
72+evalRODatabaseContextOp context (ShowConstraint name) = do
73+ DisplayResult $ T.pack (show filteredDeps)
74+ where
75+ deps = inclusionDependencies context
76+ filteredDeps = case name of
77+ "" -> deps
78+ name2 -> HS.filter (\(InclusionDependency n _ _) -> n == name2) deps
79+
80+evalRODatabaseContextOp context (ShowPlan dbExpr) = do
81+ DisplayResult $ T.pack (show plan)
82+ where
83+ plan = evalState (applyStaticDatabaseOptimization dbExpr) context
84+
85+evalRODatabaseContextOp _ (Quit) = QuitResult
TutorialD/Interpreter/RelationalExpr.hsnew file+237
@@ -0,0 +1,237 @@
1+module TutorialD.Interpreter.RelationalExpr where
2+import Text.Parsec
3+import Text.Parsec.Expr
4+import ProjectM36.Base
5+import Text.Parsec.String
6+import TutorialD.Interpreter.Base
7+import qualified Data.Text as T
8+import qualified ProjectM36.Attribute as A
9+import ProjectM36.TupleSet
10+import ProjectM36.Tuple
11+import qualified Data.HashSet as HS
12+import ProjectM36.Atom
13+import qualified Data.Vector as V
14+import qualified Data.Set as S
15+import Control.Applicative (liftA, (<*), (*>), (<$>))
16+
17+--used in projection
18+attributeListP :: Parser [AttributeName]
19+attributeListP = do
20+ attrs <- sepBy identifier comma
21+ return $ map T.pack attrs
22+
23+makeRelationP :: Parser RelationalExpr
24+makeRelationP = do
25+ reservedOp "relation"
26+ attrs <- (try makeAttributesP <|> return A.emptyAttributes)
27+ if not (A.null attrs) then do
28+ return $ MakeStaticRelation attrs emptyTupleSet
29+ else do
30+ tuples <- braces (sepBy tupleP comma)
31+ return $ MakeStaticRelation (tupleAttributes (head tuples)) (HS.fromList tuples)
32+
33+--used in relation creation
34+makeAttributesP :: Parser Attributes
35+makeAttributesP = do
36+ attrList <- braces (sepBy attributeAndTypeP comma)
37+ return $ A.attributesFromList attrList
38+
39+attributeAndTypeP :: Parser Attribute
40+attributeAndTypeP = do
41+ attrName <- identifier
42+ attrTypeName <- identifier
43+ --convert type name into type
44+ case tutDTypeToAtomType attrTypeName of
45+ Just t -> return $ Attribute (T.pack attrName) t
46+ Nothing -> fail (attrTypeName ++ " is not a valid type name.")
47+
48+tupleP :: Parser RelationTuple
49+tupleP = do
50+ reservedOp "tuple"
51+ attrAssocs <- braces (sepBy tupleAtomP comma)
52+ let attrs = A.attributesFromList $ map (\(attrName, atom) -> Attribute attrName (atomTypeForAtom atom)) attrAssocs
53+ let atoms = V.fromList $ map snd attrAssocs
54+ return $ mkRelationTuple attrs atoms
55+
56+tupleAtomP :: Parser (AttributeName, Atom)
57+tupleAtomP = do
58+ attributeName <- identifier
59+ attrType <- identifier
60+ atom <- parens (stringAtomP <|> intAtomP)
61+ case tutDTypeToAtomType attrType of
62+ Nothing -> fail (attrType ++ " is not a valid type name.")
63+ Just typeA -> if typeA == atomTypeForAtom atom then
64+ return $ (T.pack attributeName, atom)
65+ else
66+ fail "type mismatch in tuple generation"
67+
68+projectP :: Parser (RelationalExpr -> RelationalExpr)
69+projectP = do
70+ attrs <- braces attributeListP
71+ return $ Project (S.fromList attrs)
72+
73+renameClauseP :: Parser (String, String)
74+renameClauseP = do
75+ oldAttr <- identifier
76+ reservedOp "as"
77+ newAttr <- identifier
78+ return $ (oldAttr, newAttr)
79+
80+renameP :: Parser (RelationalExpr -> RelationalExpr)
81+renameP = do
82+ reservedOp "rename"
83+ (oldAttr, newAttr) <- braces renameClauseP
84+ return $ Rename (T.pack oldAttr) (T.pack newAttr)
85+
86+whereClauseP :: Parser (RelationalExpr -> RelationalExpr)
87+whereClauseP = do
88+ reservedOp "where"
89+ boolExpr <- restrictionPredicateP
90+ return $ Restrict boolExpr
91+
92+groupClauseP :: Parser ([AttributeName], String)
93+groupClauseP = do
94+ attrs <- braces attributeListP
95+ reservedOp "as"
96+ newAttrName <- identifier
97+ return $ (attrs, newAttrName)
98+
99+groupP :: Parser (RelationalExpr -> RelationalExpr)
100+groupP = do
101+ reservedOp "group"
102+ (groupAttrList, groupAttrName) <- parens groupClauseP
103+ return $ Group (S.fromList groupAttrList) (T.pack groupAttrName)
104+
105+--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.
106+ungroupP :: Parser (RelationalExpr -> RelationalExpr)
107+ungroupP = do
108+ reservedOp "ungroup"
109+ rvaAttrName <- identifier
110+ return $ Ungroup (T.pack rvaAttrName)
111+
112+extendP :: Parser (RelationalExpr -> RelationalExpr)
113+extendP = do
114+ reservedOp ":"
115+ tupleExpr <- braces tupleExpressionP
116+ return $ Extend tupleExpr
117+
118+{-
119+rewrite summarize as extend as evaluate
120+it turns out that summarize must be a relational expression primitive because it requires
121+
122+summarize SP per (SP{SNO}) add (sum(@QTY) as SUMQ) === ((SP rename {QTY as _}) group ({_} as x)) : {QTY:=sum(@x)}{S#,QTY}
123+so, in general,
124+summarize rX per (relExpr) add (func(@attr) as funcd) === ((rX rename {attr as _}) group ({_} as _)) : {QTY:=sum(@_)}{relExpr, _}
125+-}
126+{-
127+summarizeP :: Parser (RelationalExpr -> RelationalExpr)
128+summarizeP = do
129+ reservedOp "per"
130+ -- "summarize in Tutorial D requires the heading of the per relation to be a subset of that of the relation to be summarized"
131+ perExpr <- parens relExpr
132+ reservedOp "add"
133+ (funcAtomExpr, newAttrName) <- parens summaryP
134+ --rewrite summarize as extend
135+ --return $ Summarize funcAtomExpr newAttrName perExpr
136+
137+summaryP :: Parser (AtomExpr, AttributeName)
138+summaryP = do
139+ expr <- atomExprP
140+ reserved "as"
141+ attrName <- identifier
142+ return (expr, T.pack attrName)
143+-}
144+
145+relOperators = [
146+ [Postfix projectP],
147+ [Postfix renameP],
148+ [Postfix whereClauseP],
149+ [Postfix groupP],
150+ [Postfix ungroupP],
151+ [Infix (reservedOp "join" >> return Join) AssocLeft],
152+ [Infix (reservedOp "union" >> return Union) AssocLeft],
153+ [Infix (reservedOp "=" >> return Equals) AssocNone],
154+ [Postfix extendP]
155+ ]
156+
157+relExprP :: Parser RelationalExpr
158+relExprP = buildExpressionParser relOperators relTerm
159+
160+relVarP :: Parser RelationalExpr
161+relVarP = liftA (RelationVariable . T.pack) identifier
162+
163+relTerm :: Parser RelationalExpr
164+relTerm = parens relExprP
165+ <|> makeRelationP
166+ <|> relVarP
167+
168+restrictionPredicateP :: Parser RestrictionPredicateExpr
169+restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
170+ where
171+ predicateOperators = [
172+ [Prefix (reservedOp "not" >> return NotPredicate)],
173+ [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
174+ [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
175+ ]
176+ predicateTerm = parens restrictionPredicateP
177+ <|> try restrictionAttributeEqualityP
178+ <|> try relationalBooleanExprP
179+
180+relationalBooleanExprP :: Parser RestrictionPredicateExpr
181+relationalBooleanExprP = do
182+ relexpr <- relExprP
183+ return $ RelationalExprPredicate relexpr
184+
185+restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
186+restrictionAttributeEqualityP = do
187+ attributeName <- identifier
188+ reservedOp "="
189+ atomexpr <- atomExprP
190+ return $ AttributeEqualityPredicate (T.pack attributeName) atomexpr
191+
192+
193+multiTupleExpressionP :: Parser [TupleExpr]
194+multiTupleExpressionP = sepBy tupleExpressionP comma
195+
196+tupleExpressionP :: Parser TupleExpr
197+tupleExpressionP = attributeTupleExpressionP
198+
199+attributeTupleExpressionP :: Parser TupleExpr
200+attributeTupleExpressionP = do
201+ newAttr <- identifier
202+ reservedOp ":="
203+ atom <- atomExprP
204+ return $ AttributeTupleExpr (T.pack newAttr) atom
205+
206+atomExprP :: Parser AtomExpr
207+atomExprP = try functionAtomExprP <|>
208+ attributeAtomExprP <|>
209+ nakedAtomExprP <|>
210+ relationalAtomExprP
211+
212+attributeAtomExprP :: Parser AtomExpr
213+attributeAtomExprP = do
214+ _ <- string "@"
215+ attrName <- identifier
216+ return $ AttributeAtomExpr (T.pack attrName)
217+
218+nakedAtomExprP :: Parser AtomExpr
219+nakedAtomExprP = NakedAtomExpr <$> (stringAtomP <|> intAtomP)
220+
221+functionAtomExprP :: Parser AtomExpr
222+functionAtomExprP = do
223+ funcName <- identifier
224+ argList <- parens (sepBy atomExprP comma)
225+ return $ FunctionAtomExpr (T.pack funcName) argList
226+
227+relationalAtomExprP :: Parser AtomExpr
228+relationalAtomExprP = RelationAtomExpr <$> relExprP
229+
230+quotedChar = noneOf "\""
231+ <|> try (string "\"\"" >> return '"')
232+
233+stringAtomP = liftA (StringAtom . T.pack) (string "\"" *> many quotedChar <* string "\"")
234+
235+intAtomP = do
236+ intstr <- many1 digit
237+ return $ IntAtom (read intstr)
TutorialD/Interpreter/TransactionGraphOperator.hsnew file+148
@@ -0,0 +1,148 @@
1+{-# LANGUAGE GADTs #-}
2+module TutorialD.Interpreter.TransactionGraphOperator where
3+import TutorialD.Interpreter.Base
4+import Text.Parsec
5+import Text.Parsec.String
6+import ProjectM36.Base
7+import qualified Data.UUID as U
8+import qualified Data.Text as T
9+import ProjectM36.Error
10+import ProjectM36.Transaction
11+import ProjectM36.Transaction.Show
12+import ProjectM36.Relation.Show.Term
13+
14+--operators which manipulate a transaction graph
15+data TransactionGraphOperator where
16+ JumpToHead :: HeadName -> TransactionGraphOperator
17+ JumpToTransaction :: U.UUID -> TransactionGraphOperator
18+ Branch :: HeadName -> TransactionGraphOperator
19+ Commit :: TransactionGraphOperator
20+ Rollback :: TransactionGraphOperator
21+ ShowGraph :: TransactionGraphOperator
22+
23+jumpToHeadP :: Parser TransactionGraphOperator
24+jumpToHeadP = do
25+ reservedOp ":jumphead"
26+ headid <- identifier
27+ return $ JumpToHead (T.pack headid)
28+
29+jumpToTransactionP :: Parser TransactionGraphOperator
30+jumpToTransactionP = do
31+ reservedOp ":jump"
32+ uuid <- uuidP
33+ return $ JumpToTransaction uuid
34+
35+branchTransactionP :: Parser TransactionGraphOperator
36+branchTransactionP = do
37+ reservedOp ":branch"
38+ branchName <- identifier
39+ return $ Branch (T.pack branchName)
40+
41+commitTransactionP :: Parser TransactionGraphOperator
42+commitTransactionP = do
43+ reservedOp ":commit"
44+ return $ Commit
45+
46+rollbackTransactionP :: Parser TransactionGraphOperator
47+rollbackTransactionP = do
48+ reservedOp ":rollback"
49+ return $ Rollback
50+
51+showGraphP :: Parser TransactionGraphOperator
52+showGraphP = do
53+ reservedOp ":showgraph"
54+ return $ ShowGraph
55+
56+transactionGraphOpP :: Parser TransactionGraphOperator
57+transactionGraphOpP = do
58+ jumpToHeadP
59+ <|> jumpToTransactionP
60+ <|> branchTransactionP
61+ <|> commitTransactionP
62+ <|> rollbackTransactionP
63+ <|> showGraphP
64+
65+uuidP :: Parser U.UUID
66+uuidP = do
67+ uuidStr <- many (alphaNum <|> char '-')
68+ case U.fromString uuidStr of
69+ Nothing -> fail "Invalid uuid string"
70+ Just uuid -> return uuid
71+
72+-- returns the new "current" transaction, updated graph, and tutorial d result
73+-- the current transaction is not part of the transaction graph until it is committed
74+evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
75+
76+--affects only disconncted transaction
77+evalGraphOp _ _ graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
78+ Left err -> Left err
79+ Right parentTrans -> Right (newTrans, graph, QuietSuccessResult)
80+ where
81+ newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
82+
83+-- switch from one head to another
84+-- affects only disconnectedtransaction
85+evalGraphOp _ _ graph (JumpToHead headName) =
86+ case transactionForHead headName graph of
87+ Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in
88+ Right (disconnectedTrans, graph, QuietSuccessResult)
89+ Nothing -> Left $ NoSuchHeadNameError headName
90+-- add new head pointing to branchPoint
91+-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
92+-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
93+ {-
94+evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
95+ Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
96+ Just parentTrans -> case addBranch newBranchName parentTrans graph of
97+ Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
98+ Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
99+ where
100+ newDiscon = DisconnectedTransaction (transactionUUID parentTrans) disconContext
101+-}
102+
103+-- create a new commit and add it to the heads
104+-- 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)
105+evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
106+ Left err -> Left err
107+ Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
108+ Left err -> Left err
109+ Right (_, newGraph) -> Right (newDiscon, newGraph, QuietSuccessResult)
110+ where
111+ newDiscon = DisconnectedTransaction newUUID disconContext
112+
113+-- add the disconnected transaction to the graph
114+-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
115+evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of
116+ Left err -> Left err
117+ Right parentTransaction -> case headNameForTransaction parentTransaction graph of
118+ Nothing -> Left $ TransactionIsNotAHeadError parentUUID
119+ Just headName -> case maybeUpdatedGraph of
120+ Left err-> Left err
121+ Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph, QuietSuccessResult)
122+ where
123+ newDisconnectedTrans = newDisconnectedTransaction newTransUUID context
124+ maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph
125+
126+-- refresh the disconnected transaction, return the same graph
127+evalGraphOp _ (DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of
128+ Left err -> Left err
129+ Right parentTransaction -> Right (newDiscon, graph, QuietSuccessResult)
130+ where
131+ newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)
132+
133+--display transaction graph as relation
134+evalGraphOp _ discon graph ShowGraph = do
135+ graphStr <- graphAsRelation discon graph
136+ return (discon, graph, DisplayResult $ showRelation graphStr)
137+
138+{-
139+-- for interpreter-specific operations
140+interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
141+interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of
142+ Left _ -> (trans, transGraph, NoActionResult)
143+ Right ops -> case ops of
144+ Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
145+ Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
146+ Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))
147+ Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
148+-}
benchmark/bigrel.hs+19−21
@@ -4,7 +4,7 @@ import ProjectM36.Relation
4import ProjectM36.Tuple
4import ProjectM36.Tuple
5import ProjectM36.Relation.Show.CSV
5import ProjectM36.Relation.Show.CSV
6import ProjectM36.Relation.Show.HTML
6import ProjectM36.Relation.Show.HTML
7−import TutorialD.Interpreter (interpret)
7+import TutorialD.Interpreter.DatabaseExpr (interpretDatabaseExpr)
8import ProjectM36.RelationalExpression
8import ProjectM36.RelationalExpression
9import qualified Data.HashSet as HS
9import qualified Data.HashSet as HS
10import qualified Data.ByteString.Lazy.Char8 as BS
10import qualified Data.ByteString.Lazy.Char8 as BS
@@ -12,11 +12,10 @@ import qualified Data.IntMap as IM
12import qualified Data.Hashable as Hash
12import qualified Data.Hashable as Hash
13import qualified Data.Vector as V
13import qualified Data.Vector as V
14import Options.Applicative
14import Options.Applicative
15−import Control.Monad.State
16import qualified Data.Map as M
15import qualified Data.Map as M
17import qualified Data.Text.IO as TIO
16import qualified Data.Text.IO as TIO
18import System.IO
17import System.IO
19−
18+
20dumpcsv :: Relation -> IO ()
19dumpcsv :: Relation -> IO ()
21dumpcsv = BS.putStrLn . relationAsCSV
20dumpcsv = BS.putStrLn . relationAsCSV
22
21
@@ -30,7 +29,7 @@ parseTupleCount = option auto (short 't' <> long "tuple-count")
30
29
31parseTutD :: Parser String
30parseTutD :: Parser String
32parseTutD = strOption (short 'd' <> long "tutoriald")
31parseTutD = strOption (short 'd' <> long "tutoriald")
33−
32+
34parseArgs :: Parser BigrelArgs
33parseArgs :: Parser BigrelArgs
35parseArgs = BigrelArgs <$> parseAttributeCount <*> parseTupleCount <*> parseTutD
34parseArgs = BigrelArgs <$> parseAttributeCount <*> parseTupleCount <*> parseTutD
36
35
@@ -39,37 +38,36 @@ main = do
39 bigrelArgs <- execParser $ info (helper <*> parseArgs) fullDesc
38 bigrelArgs <- execParser $ info (helper <*> parseArgs) fullDesc
40 --matrixRestrictRun
39 --matrixRestrictRun
41 matrixRun bigrelArgs
40 matrixRun bigrelArgs
42− --vectorMatrixRun
41+ --vectorMatrixRun
43 --intmapMatrixRun
42 --intmapMatrixRun
44−
43+
45matrixRestrictRun :: IO ()
44matrixRestrictRun :: IO ()
46−matrixRestrictRun = do
45+matrixRestrictRun = do
47 case matrixRelation 100 1000000 of
46 case matrixRelation 100 1000000 of
48 Left err -> putStrLn (show err)
47 Left err -> putStrLn (show err)
49 Right rel -> case restrict (\tuple -> atomForAttributeName "0" tuple == Right (IntAtom 5)) rel of
48 Right rel -> case restrict (\tuple -> atomForAttributeName "0" tuple == Right (IntAtom 5)) rel of
50 Left err -> putStrLn (show err)
49 Left err -> putStrLn (show err)
51 Right rel -> dumpcsv rel
50 Right rel -> dumpcsv rel
52−
51+
53matrixRun :: BigrelArgs -> IO ()
52matrixRun :: BigrelArgs -> IO ()
54−matrixRun (BigrelArgs attributeCount tupleCount tutd) = do
53+matrixRun (BigrelArgs attributeCount tupleCount tutd) = do
55 case matrixRelation attributeCount tupleCount of
54 case matrixRelation attributeCount tupleCount of
56 Left err -> putStrLn (show err)
55 Left err -> putStrLn (show err)
57 Right rel -> if tutd == "" then
56 Right rel -> if tutd == "" then
58 putStrLn "Done."
57 putStrLn "Done."
59− else do
58+ else do
60 let setx = Assign "x" (ExistingRelation rel)
59 let setx = Assign "x" (ExistingRelation rel)
61− (_, context) = runState (evalContextExpr setx) dateExamples
60+ interpreted = interpretDatabaseExpr dateExamples tutd
62− (err, context2) = interpret context tutd
63− case err of
61+ case interpreted of
64− Nothing -> TIO.putStrLn $ relationAsHTML ((relationVariables context2) M.! "x")
62+ Right context' -> TIO.putStrLn $ relationAsHTML ((relationVariables context') M.! "x")
65− Just err -> hPutStrLn stderr (show err)
63+ Left err -> hPutStrLn stderr (show err)
66−
64+
67−
65+
68intmapMatrixRun :: IO ()
66intmapMatrixRun :: IO ()
69−intmapMatrixRun = do
67+intmapMatrixRun = do
70 let matrix = intmapMatrixRelation 100 100000
68 let matrix = intmapMatrixRelation 100 100000
71 putStrLn (show matrix)
69 putStrLn (show matrix)
72−
70+
73--compare IntMap speed and size
71--compare IntMap speed and size
74--this is about 3 times faster (9 minutes) for 10x100000 and uses 800 MB
72--this is about 3 times faster (9 minutes) for 10x100000 and uses 800 MB
75intmapMatrixRelation :: Int -> Int -> HS.HashSet (IM.IntMap Atom)
73intmapMatrixRelation :: Int -> Int -> HS.HashSet (IM.IntMap Atom)
@@ -91,6 +89,6 @@ vectorMatrixRelation :: Int -> Int -> HS.HashSet (V.Vector Atom)
91vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]
89vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]
92 where
90 where
93 mapper tupCount = V.replicate attributeCount (IntAtom tupCount)
91 mapper tupCount = V.replicate attributeCount (IntAtom tupCount)
94−
92+
95−instance Hash.Hashable (V.Vector Atom) where
93+instance Hash.Hashable (V.Vector Atom) where
96 hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)
94 hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)
project-m36.cabal+8−3
@@ -23,13 +23,18 @@ Library
23 ProjectM36.Relation.Show.Term,
23 ProjectM36.Relation.Show.Term,
24 ProjectM36.Relation.Show.CSV
24 ProjectM36.Relation.Show.CSV
25 GHC-Options: -Wall -rtsopts
25 GHC-Options: -Wall -rtsopts
26−
26+
27Executable tutd
27Executable tutd
28 Build-Depends: base
28 Build-Depends: base
29 Other-Modules: ProjectM36.Error,
29 Other-Modules: ProjectM36.Error,
30 ProjectM36.Base,
30 ProjectM36.Base,
31 ProjectM36.RelationalExpression,
31 ProjectM36.RelationalExpression,
32− ProjectM36.Transaction
32+ ProjectM36.Transaction,
33+ TutorialD.Interpreter,
34+ TutorialD.Interpreter.Base,
35+ TutorialD.Interpreter.DatabaseExpr,
36+ TutorialD.Interpreter.RODatabaseContextOperator,
37+ TutorialD.Interpreter.TransactionGraphOperator
33 main-is: TutorialD/tutd.hs
38 main-is: TutorialD/tutd.hs
34 GHC-Options: -Wall
39 GHC-Options: -Wall
35
40
@@ -66,4 +71,4 @@ benchmark bench
66 type: exitcode-stdio-1.0
71 type: exitcode-stdio-1.0
67 main-is: benchmark/Relation.hs
72 main-is: benchmark/Relation.hs
68 build-depends: base,criterion
73 build-depends: base,criterion
69− GHC-Options: -Wall -rtsopts
74+ GHC-Options: -Wall -rtsopts
test/TutorialD/Interpreter.hs+61−37
@@ -1,4 +1,5 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2+import TutorialD.Interpreter.DatabaseExpr
2import TutorialD.Interpreter
3import TutorialD.Interpreter
3import Test.HUnit
4import Test.HUnit
4import ProjectM36.RelationalExpression
5import ProjectM36.RelationalExpression
@@ -20,11 +21,11 @@ import qualified Data.Vector as V
20
21
21--urgent: add group and ungroup tests- I missed the group relation type bug
22--urgent: add group and ungroup tests- I missed the group relation type bug
22main :: IO ()
23main :: IO ()
23−main = do
24+main = do
24 tcounts <- runTestTT (TestList tests)
25 tcounts <- runTestTT (TestList tests)
25 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
26 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
26 where
27 where
27− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest]
28+ tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest]
28 simpleRelTests = [("x:=true", Right relationTrue),
29 simpleRelTests = [("x:=true", Right relationTrue),
29 ("x:=false", Right relationFalse),
30 ("x:=false", Right relationFalse),
30 ("x:=true union false", Right relationTrue),
31 ("x:=true union false", Right relationTrue),
@@ -65,10 +66,10 @@ main = do
65 ("x:=S where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),
66 ("x:=S where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),
66 ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (A.attributesFromList [ Attribute "STATUS" IntAtomType]) (HS.singleton $ mkRelationTuple (A.attributesFromList [Attribute "STATUS" IntAtomType]) (V.fromList [IntAtom 50]))),
67 ("a:=S; update a (STATUS:=50); x:=a{STATUS}", mkRelation (A.attributesFromList [ Attribute "STATUS" IntAtomType]) (HS.singleton $ mkRelationTuple (A.attributesFromList [Attribute "STATUS" IntAtomType]) (V.fromList [IntAtom 50]))),
67 --atom function tests
68 --atom function tests
68− ("x:=((S : {STATUS2 := add(10,@STATUS)}) where STATUS2=add(10,@STATUS)){CITY,S#,SNAME,STATUS}", Right suppliersRel),
69+ ("x:=((S : {STATUS2 := add(10,@STATUS)}) where STATUS2=add(10,@STATUS)){CITY,S#,SNAME,STATUS}", Right suppliersRel),
69 ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "SNAME" tuple == (Right $ StringAtom "Blake") then updateTuple (M.singleton "CITY" (StringAtom "Boston")) tuple else tuple) suppliersRel),
70 ("x:=S; update x where SNAME=\"Blake\" (CITY:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "SNAME" tuple == (Right $ StringAtom "Blake") then updateTuple (M.singleton "CITY" (StringAtom "Boston")) tuple else tuple) suppliersRel),
70 ("x:=relation{tuple{a int(5)}} : {b:=S}", mkRelation extendTestAttributes (HS.singleton $ mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel]))),
71 ("x:=relation{tuple{a int(5)}} : {b:=S}", mkRelation extendTestAttributes (HS.singleton $ mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel]))),
71− --relatom function tests
72+ --relatom function tests
72 ("x:=((S group ({CITY} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (HS.singleton $ mkRelationTuple groupCountAttrs (V.singleton $ IntAtom 1))),
73 ("x:=((S group ({CITY} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (HS.singleton $ mkRelationTuple groupCountAttrs (V.singleton $ IntAtom 1))),
73 ("x:=(SP group ({S#} as y)) ungroup y", Right supplierProductsRel),
74 ("x:=(SP group ({S#} as y)) ungroup y", Right supplierProductsRel),
74 ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=max(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),
75 ("x:=((SP{S#,QTY}) group ({QTY} as x):{z:=max(@x)}){S#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [StringAtom s,IntAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),
@@ -80,25 +81,25 @@ main = do
80assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion
81assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion
81assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted
82assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted
82 where
83 where
83− interpreted = case interpret databaseContext tutd of
84+ interpreted = case interpretDatabaseExpr databaseContext tutd of
84− (Just err, _) -> Left err
85+ Left err -> Left err
85− (Nothing, context) -> case M.lookup "x" (relationVariables context) of
86+ Right context -> case M.lookup "x" (relationVariables context) of
86 Nothing -> Left $ RelVarNotDefinedError "x"
87 Nothing -> Left $ RelVarNotDefinedError "x"
87− Just rel -> Right rel
88+ Just rel -> Right rel
88−
89+
89transactionGraphBasicTest :: Test
90transactionGraphBasicTest :: Test
90transactionGraphBasicTest = TestCase $ do
91transactionGraphBasicTest = TestCase $ do
91 (_, graph) <- dateExamplesGraph
92 (_, graph) <- dateExamplesGraph
92 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
93 assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing
93−
94+
94−--add a new transaction to the graph, validate it is in the graph
95+--add a new transaction to the graph, validate it is in the graph
95transactionGraphAddCommitTest :: Test
96transactionGraphAddCommitTest :: Test
96−transactionGraphAddCommitTest = TestCase $ do
97+transactionGraphAddCommitTest = TestCase $ do
97 ((DisconnectedTransaction firstUUID context), origGraph) <- dateExamplesGraph
98 ((DisconnectedTransaction firstUUID context), origGraph) <- dateExamplesGraph
98 freshUUID <- nextRandom
99 freshUUID <- nextRandom
99− case interpret context "x:=S" of
100+ case interpretDatabaseExpr context "x:=S" of
100− (Just err, _) -> assertFailure (show err)
101+ Left err -> assertFailure (show err)
101− (Nothing, newContext) -> do
102+ Right newContext -> do
102 let discon = newDisconnectedTransaction firstUUID newContext
103 let discon = newDisconnectedTransaction firstUUID newContext
103 let addTrans = addDisconnectedTransaction freshUUID "master" discon origGraph
104 let addTrans = addDisconnectedTransaction freshUUID "master" discon origGraph
104 case addTrans of
105 case addTrans of
@@ -107,37 +108,37 @@ transactionGraphAddCommitTest = TestCase $ do
107 assertBool "transaction in graph" (isRight $ transactionForUUID freshUUID graph)
108 assertBool "transaction in graph" (isRight $ transactionForUUID freshUUID graph)
108 assertEqual "validate fresh commit with deleted S" (validateGraph graph) Nothing
109 assertEqual "validate fresh commit with deleted S" (validateGraph graph) Nothing
109 assertEqual "ensure S was deleted in newContext" (M.lookup "x" (relationVariables (transactionContext newTrans))) (Just suppliersRel)
110 assertEqual "ensure S was deleted in newContext" (M.lookup "x" (relationVariables (transactionContext newTrans))) (Just suppliersRel)
110−
111+
111transactionRollbackTest :: Test
112transactionRollbackTest :: Test
112−transactionRollbackTest = TestCase $ do
113+transactionRollbackTest = TestCase $ do
113 ((DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
114 ((DisconnectedTransaction firstUUID origContext), graph) <- dateExamplesGraph
114 freshUUID <- nextRandom
115 freshUUID <- nextRandom
115− case transactionForUUID firstUUID graph of
116+ case transactionForUUID firstUUID graph of
116 Left err -> assertFailure (show err)
117 Left err -> assertFailure (show err)
117 Right _ -> do
118 Right _ -> do
118− case interpret origContext "x:=S" of
119+ case interpretDatabaseExpr origContext "x:=S" of
119− (Just err, _) -> assertFailure (show err)
120+ Left err -> assertFailure (show err)
120− (Nothing, newContext) -> do
121+ Right newContext -> do
121 let discon = newDisconnectedTransaction firstUUID newContext
122 let discon = newDisconnectedTransaction firstUUID newContext
122− let ((DisconnectedTransaction _ newContext2), newGraph, _) = interpretOps freshUUID discon graph ":rollback"
123+ let (_, (DisconnectedTransaction _ newContext2), newGraph) = interpret freshUUID discon graph ":rollback"
123 assertEqual "validate context" (M.lookup "x" (relationVariables newContext2)) Nothing
124 assertEqual "validate context" (M.lookup "x" (relationVariables newContext2)) Nothing
124 assertEqual "validate graph" graph newGraph
125 assertEqual "validate graph" graph newGraph
125
126
126--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
127--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present
127−transactionJumpTest :: Test
128+transactionJumpTest :: Test
128transactionJumpTest = TestCase $ do
129transactionJumpTest = TestCase $ do
129− ((DisconnectedTransaction firstUUID origContext), origGraph) <- dateExamplesGraph
130+ ((DisconnectedTransaction firstUUID origContext), origGraph) <- dateExamplesGraph
130 freshUUID <- nextRandom
131 freshUUID <- nextRandom
131 case transactionForUUID firstUUID origGraph of
132 case transactionForUUID firstUUID origGraph of
132 Left err -> assertFailure (show err)
133 Left err -> assertFailure (show err)
133 Right _ -> do
134 Right _ -> do
134− case interpret origContext "x:=S" of
135+ case interpretDatabaseExpr origContext "x:=S" of
135− (Just err, _) -> assertFailure (show err)
136+ Left err -> assertFailure (show err)
136− (Nothing, newContext) -> do
137+ Right newContext -> do
137 --modify the second transaction
138 --modify the second transaction
138− case interpret newContext "x:=S" of
139+ case interpretDatabaseExpr newContext "x:=S" of
139− (Just err, _) -> assertFailure (show err)
140+ Left err-> assertFailure (show err)
140− (Nothing, newContext2) -> do
141+ Right newContext2 -> do
141 --add the transaction
142 --add the transaction
142 let discon = newDisconnectedTransaction firstUUID newContext2
143 let discon = newDisconnectedTransaction firstUUID newContext2
143 let addTrans = addDisconnectedTransaction freshUUID "master" discon origGraph
144 let addTrans = addDisconnectedTransaction freshUUID "master" discon origGraph
@@ -145,20 +146,20 @@ transactionJumpTest = TestCase $ do
145 Left err -> assertFailure (show err)
146 Left err -> assertFailure (show err)
146 Right (_, graph) -> do
147 Right (_, graph) -> do
147 --jump to the first transaction
148 --jump to the first transaction
148− let ((DisconnectedTransaction parentUUID newContext3), newGraph, _) = interpretOps freshUUID discon graph (":jump " ++ show firstUUID)
149+ let (_, (DisconnectedTransaction parentUUID newContext3), newGraph) = interpret freshUUID discon graph (":jump " ++ show firstUUID)
149 assertEqual "validate discon" parentUUID firstUUID
150 assertEqual "validate discon" parentUUID firstUUID
150 assertEqual "validate discon2" Nothing (M.lookup "x" (relationVariables newContext3))
151 assertEqual "validate discon2" Nothing (M.lookup "x" (relationVariables newContext3))
151 assertEqual "validate graph" transactionUUIDs (S.map transactionUUID (transactionsForGraph newGraph))
152 assertEqual "validate graph" transactionUUIDs (S.map transactionUUID (transactionsForGraph newGraph))
152 where
153 where
153 transactionUUIDs = S.fromList [firstUUID, freshUUID]
154 transactionUUIDs = S.fromList [firstUUID, freshUUID]
154−
155+
155--branch from the first transaction and verify that there are two heads
156--branch from the first transaction and verify that there are two heads
156−transactionBranchTest :: Test
157+transactionBranchTest :: Test
157transactionBranchTest = TestCase $ do
158transactionBranchTest = TestCase $ do
158 (origDiscon@(DisconnectedTransaction firstUUID origContext), origGraph) <- dateExamplesGraph
159 (origDiscon@(DisconnectedTransaction firstUUID origContext), origGraph) <- dateExamplesGraph
159 freshUUID1 <- nextRandom
160 freshUUID1 <- nextRandom
160 freshUUID2 <- nextRandom
161 freshUUID2 <- nextRandom
161− case transactionForUUID firstUUID origGraph of
162+ case transactionForUUID firstUUID origGraph of
162 Left err -> assertFailure (show err)
163 Left err -> assertFailure (show err)
163 Right _ -> do
164 Right _ -> do
164 let disconMaster = newDisconnectedTransaction firstUUID origContext
165 let disconMaster = newDisconnectedTransaction firstUUID origContext
@@ -168,15 +169,38 @@ transactionBranchTest = TestCase $ do
168 Left err -> assertFailure (show err)
169 Left err -> assertFailure (show err)
169 Right (_, graph) -> do
170 Right (_, graph) -> do
170 --add a third transaction to the "test" branch
171 --add a third transaction to the "test" branch
171− let (_, newGraph, _) = interpretOps freshUUID2 origDiscon graph ":branch test"
172+ let (_, _, newGraph) = interpret freshUUID2 origDiscon graph ":branch test"
172 assertEqual "verify test head" freshUUID2 $ maybeTransUUID (transactionForHead "test" newGraph)
173 assertEqual "verify test head" freshUUID2 $ maybeTransUUID (transactionForHead "test" newGraph)
173 assertEqual "verify master head" freshUUID1 $ maybeTransUUID (transactionForHead "master" newGraph)
174 assertEqual "verify master head" freshUUID1 $ maybeTransUUID (transactionForHead "master" newGraph)
174 where
175 where
175 maybeTransUUID t = maybe nil transactionUUID t
176 maybeTransUUID t = maybe nil transactionUUID t
176−
177+
178+simpleJoinTest :: Test
179+simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=S join SP"
180+ where
181+ attrs = A.attributesFromList [Attribute "CITY" StringAtomType,
182+ Attribute "QTY" IntAtomType,
183+ Attribute "P#" StringAtomType,
184+ Attribute "S#" StringAtomType,
185+ Attribute "SNAME" StringAtomType,
186+ Attribute "STATUS" IntAtomType]
187+ joinedRel = mkRelationFromList attrs [[StringAtom "London", IntAtom 100, StringAtom "P6", StringAtom "S1", StringAtom "Smith", IntAtom 20],
188+ [StringAtom "London", IntAtom 400, StringAtom "P3", StringAtom "S1", StringAtom "Smith", IntAtom 20],
189+ [StringAtom "London", IntAtom 400, StringAtom "P5", StringAtom "S4", StringAtom "Clark", IntAtom 20],
190+ [StringAtom "London", IntAtom 300, StringAtom "P1", StringAtom "S1", StringAtom "Smith", IntAtom 20],
191+ [StringAtom "Paris", IntAtom 200, StringAtom "P2", StringAtom "S3", StringAtom "Blake", IntAtom 30],
192+ [StringAtom "Paris", IntAtom 300, StringAtom "P1", StringAtom "S2", StringAtom "Jones", IntAtom 10],
193+ [StringAtom "London", IntAtom 100, StringAtom "P5", StringAtom "S1", StringAtom "Smith", IntAtom 20],
194+ [StringAtom "London", IntAtom 300, StringAtom "P4", StringAtom "S4", StringAtom "Clark", IntAtom 20],
195+ [StringAtom "Paris", IntAtom 400, StringAtom "P2", StringAtom "S2", StringAtom "Jones", IntAtom 10],
196+ [StringAtom "London", IntAtom 200, StringAtom "P2", StringAtom "S1", StringAtom "Smith", IntAtom 20],
197+ [StringAtom "London", IntAtom 200, StringAtom "P4", StringAtom "S1", StringAtom "Smith", IntAtom 20],
198+ [StringAtom "London", IntAtom 200, StringAtom "P2", StringAtom "S4", StringAtom "Clark", IntAtom 20]
199+ ]
200+
177dateExamplesGraph :: IO (DisconnectedTransaction, TransactionGraph)
201dateExamplesGraph :: IO (DisconnectedTransaction, TransactionGraph)
178dateExamplesGraph = do
202dateExamplesGraph = do
179− firstTransactionUUID <- nextRandom
203+ firstTransactionUUID <- nextRandom
180 let graph = bootstrapTransactionGraph firstTransactionUUID dateExamples
204 let graph = bootstrapTransactionGraph firstTransactionUUID dateExamples
181 let discon = newDisconnectedTransaction firstTransactionUUID dateExamples
205 let discon = newDisconnectedTransaction firstTransactionUUID dateExamples
182 return (discon, graph)
206 return (discon, graph)