git.iko.soy/project-m36
on 694fd44 help sign in
project-m36/TutorialDInterpreter.hs
584 lines 22 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialDInterpreter where
3import Relation
4import RelationType
5import RelationTuple
6import RelationTupleSet
7import RelationalError
8import RelationExpr
9import RelationTerm
10import RelationStaticOptimizer
11import RelationalTransaction
12import RelationalTransactionShow
13import Text.Parsec
14import Text.Parsec.String
15import Text.Parsec.Expr
16import Text.Parsec.Language
17import qualified Text.Parsec.Token as Token
18import qualified Data.Set as S
19import qualified Data.HashSet as HS
20import qualified Data.Map as M
21import qualified Data.List as L
22import Control.Applicative (liftA, (<*), (*>))
23import Control.Monad.State
24import System.Console.Haskeline
25import System.IO
26import System.Directory (getHomeDirectory)
27import qualified Data.UUID as U
28import Data.UUID.V4 (nextRandom)
30{-
31List of Tutorial D operators:
32show relation expression type :: relexpr -> context -> opresult
33show relvar :: relvar name -> context -> opresult
34quit :: ()
35show graph :: graph -> DisconnectedTransaction -> opresult
36show constraints :: context -> opresult
37jump to head :: head name -> graph -> DisconnectedTransaction (graph unchanged)
38jump to UUID :: uuid -> graph -> DisconnectedTransaction (graph unchanged)
39branch :: uuid -> branch name -> graph -> (DisconnectedTransation, graph)
40commit :: uuid -> DisconnectedTransaction -> graph -> (DisconnectedTransaction, graph)
41rollback :: DisconnectedTransaction -> graph -> (DisconnectedTransaction, graph)
44-}
45lexer :: Token.TokenParser ()
46lexer = Token.makeTokenParser tutD
47 where tutD = emptyDef {
48 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
49 Token.reservedNames = [],
50 Token.identStart = letter <|> char '_',
51 Token.identLetter = alphaNum <|> char '_' <|> char '#'} -- # needed for Date examples
53parens = Token.parens lexer
54reservedOp = Token.reservedOp lexer
55reserved = Token.reserved lexer
56braces = Token.braces lexer
57identifier = Token.identifier lexer
58comma = Token.comma lexer
59semi = Token.semi lexer
61uuidP :: Parser U.UUID
62uuidP = do
63 uuidStr <- many (alphaNum <|> char '-')
64 case U.fromString uuidStr of
65 Nothing -> fail "Invalid uuid string"
66 Just uuid -> return uuid
68--used in projection
69attributeList :: Parser [AttributeName]
70attributeList = sepBy identifier comma
72makeRelation :: Parser RelationalExpr
73makeRelation = do
74 reservedOp "relation"
75 attrs <- (try makeAttributes <|> return M.empty)
76 if not (M.null attrs) then do
77 return $ MakeStaticRelation attrs emptyTupleSet
78 else do
79 tuples <- braces (sepBy tupleP comma)
80 return $ MakeStaticRelation (tupleAttributes (head tuples)) (HS.fromList tuples)
82--used in relation creation
83makeAttributes :: Parser Attributes
84makeAttributes = do
85 attrList <- braces (sepBy attributeAndType comma)
86 return $ M.fromList $ map toAttributeAssocList attrList
87 where
88 toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
90attributeAndType :: Parser Attribute
91attributeAndType = do
92 attrName <- identifier
93 attrTypeName <- identifier
94 --convert type name into type
95 case tutDTypeToAtomType attrTypeName of
96 Just t -> return $ Attribute attrName t
97 Nothing -> fail (attrTypeName ++ " is not a valid type name.")
99tupleP :: Parser RelationTuple
100tupleP = do
101 reservedOp "tuple"
102 attrValues <- braces (sepBy tupleAtomP comma)
103 return $ RelationTuple (M.fromList attrValues)
105tupleAtomP :: Parser (AttributeName, Atom)
106tupleAtomP = do
107 attributeName <- identifier
108 attrType <- identifier
109 atom <- parens (stringAtomP <|> intAtomP)
110 case tutDTypeToAtomType attrType of
111 Nothing -> fail (attrType ++ " is not a valid type name.")
112 Just typeA -> if typeA == atomTypeForAtom atom then
113 return $ (attributeName, atom)
114 else
115 fail "type mismatch in tuple generation"
117--convert Tutorial D type to AtomType
118tutDTypeToAtomType :: String -> Maybe AtomType
119tutDTypeToAtomType tutDType = case tutDType of
120 "char" -> Just StringAtomType
121 "int" -> Just IntAtomType
122 _ -> Nothing
124atomTypeToTutDType :: AtomType -> Maybe String
125atomTypeToTutDType atomType = case atomType of
126 StringAtomType -> Just "char"
127 IntAtomType -> Just "int"
128 --RelationAtomType rel ->
129 _ -> Nothing
131relVarP :: Parser RelationalExpr
132relVarP = liftA RelationVariable identifier
134relTerm = parens relExpr
135 <|> makeRelation
136 <|> relVarP
138projectOp = do
139 attrs <- braces attributeList
140 return $ Project (S.fromList attrs)
142assignP :: Parser DatabaseExpr
143assignP = do
144 relVarName <- try $ do
145 relVarName <- identifier
146 reservedOp ":="
147 return relVarName
148 expr <- relExpr
149 return $ Assign relVarName expr
151renameClause = do
152 oldAttr <- identifier
153 reservedOp "as"
154 newAttr <- identifier
155 return $ (oldAttr, newAttr)
157renameP :: Parser (RelationalExpr -> RelationalExpr)
158renameP = do
159 reservedOp "rename"
160 (oldAttr, newAttr) <- braces renameClause
161 return $ Rename oldAttr newAttr
163whereClauseP = do
164 reservedOp "where"
165 boolExpr <- restrictionPredicateP
166 return $ Restrict boolExpr
168groupClause = do
169 attrs <- braces attributeList
170 reservedOp "as"
171 newAttrName <- identifier
172 return $ (attrs, newAttrName)
174groupP :: Parser (RelationalExpr -> RelationalExpr)
175groupP = do
176 reservedOp "group"
177 (groupAttrList, groupAttrName) <- parens groupClause
178 return $ Group (S.fromList groupAttrList) groupAttrName
180--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.
181ungroupP :: Parser (RelationalExpr -> RelationalExpr)
182ungroupP = do
183 reservedOp "ungroup"
184 rvaAttrName <- identifier
185 return $ Ungroup rvaAttrName
187relOperators = [
188 [Postfix projectOp],
189 [Postfix renameP],
190 [Postfix whereClauseP],
191 [Postfix groupP],
192 [Postfix ungroupP],
193 [Infix (reservedOp "join" >> return Join) AssocLeft],
194 [Infix (reservedOp "union" >> return Union) AssocLeft],
195 [Infix (reservedOp "=" >> return Equals) AssocNone]
196 ]
198relExpr :: Parser RelationalExpr
199relExpr = buildExpressionParser relOperators relTerm
201databaseExpr :: Parser DatabaseExpr
202databaseExpr = insertP
203 <|> deleteP
204 <|> updateP
205 <|> constraintP
206 <|> defineP
207 <|> undefineP
208 <|> assignP
210multipleDatabaseExpr :: Parser DatabaseExpr
211multipleDatabaseExpr = do
212 exprs <- sepBy1 databaseExpr semi
213 return $ MultipleExpr exprs
215insertP :: Parser DatabaseExpr
216insertP = do
217 reservedOp "insert"
218 relvar <- identifier
219 expr <- relExpr
220 return $ Insert relvar expr
222defineP :: Parser DatabaseExpr
223defineP = do
224 relVarName <- try $ do
225 relVarName <- identifier
226 reservedOp "::"
227 return relVarName
228 attributes <- makeAttributes
229 return $ Define relVarName attributes
231undefineP :: Parser DatabaseExpr
232undefineP = do
233 reservedOp "undefine"
234 relVarName <- identifier
235 return $ Undefine relVarName
237deleteP :: Parser DatabaseExpr
238deleteP = do
239 reservedOp "delete"
240 relVarName <- identifier
241 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
242 return $ Delete relVarName predicate
244updateP :: Parser DatabaseExpr
245updateP = do
246 reservedOp "update"
247 relVarName <- identifier
248 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
249 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
250 return $ Update relVarName attributeAssignments predicate
252constraintP :: Parser DatabaseExpr
253constraintP = do
254 reservedOp "constraint"
255 constraintName <- identifier
256 subset <- relExpr
257 reservedOp "in"
258 superset <- relExpr
259 return $ AddInclusionDependency (InclusionDependency constraintName subset superset)
261attributeAssignment :: Parser (String, Atom)
262attributeAssignment = do
263 attrName <- identifier
264 reservedOp ":="
265 atom <- stringAtomP <|> intAtomP
266 return $ (attrName, atom)
268parseString :: String -> Either RelationalError DatabaseExpr
269parseString str = case parse (multipleDatabaseExpr <* eof) "" str of
270 Left err -> Left $ ParseError (show err)
271 Right r -> Right r
273--operators which only rely on database context reading
274data ContextOperator where
275 ShowRelation :: RelationalExpr -> ContextOperator
276 ShowRelationType :: RelationalExpr -> ContextOperator
277 ShowConstraint :: String -> ContextOperator
278 ShowPlan :: DatabaseExpr -> ContextOperator
279 Quit :: ContextOperator
280 deriving (Show)
282--operators which manipulate a transaction graph
283data GraphOperator where
284 JumpToHead :: String -> GraphOperator
285 JumpToTransaction :: U.UUID -> GraphOperator
286 Branch :: HeadName -> GraphOperator
287 Commit :: GraphOperator
288 Rollback :: GraphOperator
289 ShowGraph :: GraphOperator
291typeP :: Parser ContextOperator
292typeP = do
293 reservedOp ":type"
294 expr <- relExpr
295 return $ ShowRelationType expr
297showRelP :: Parser ContextOperator
298showRelP = do
299 reservedOp ":showexpr"
300 expr <- relExpr
301 return $ ShowRelation expr
303showPlanP :: Parser ContextOperator
304showPlanP = do
305 reservedOp ":showplan"
306 expr <- databaseExpr
307 return $ ShowPlan expr
309quitP :: Parser ContextOperator
310quitP = do
311 reservedOp ":quit"
312 return Quit
314showConstraintsP :: Parser ContextOperator
315showConstraintsP = do
316 reservedOp ":constraints"
317 constraintName <- option "" identifier
318 return $ ShowConstraint constraintName
320jumpToHeadP :: Parser GraphOperator
321jumpToHeadP = do
322 reservedOp ":jumphead"
323 head <- identifier
324 return $ JumpToHead head
326jumpToTransactionP :: Parser GraphOperator
327jumpToTransactionP = do
328 reservedOp ":jump"
329 uuid <- uuidP
330 return $ JumpToTransaction uuid
332branchTransactionP :: Parser GraphOperator
333branchTransactionP = do
334 reservedOp ":branch"
335 branchName <- identifier
336 return $ Branch branchName
338commitTransactionP :: Parser GraphOperator
339commitTransactionP = do
340 reservedOp ":commit"
341 return $ Commit
343rollbackTransactionP :: Parser GraphOperator
344rollbackTransactionP = do
345 reservedOp ":rollback"
346 return $ Rollback
348showGraphP :: Parser GraphOperator
349showGraphP = do
350 reservedOp ":showgraph"
351 return $ ShowGraph
353transactionGraphOps = do
354 jumpToHeadP
355 <|> jumpToTransactionP
356 <|> branchTransactionP
357 <|> commitTransactionP
358 <|> rollbackTransactionP
359 <|> showGraphP
361contextOps :: Parser ContextOperator
362contextOps = typeP
363 <|> showRelP
364 <|> showConstraintsP
365 <|> showPlanP
366 <|> quitP
368interpreterOps :: Parser (Either ContextOperator GraphOperator)
369interpreterOps = liftM Left contextOps <|> liftM Right transactionGraphOps
371showRelationAttributes :: Relation -> String
372showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
373 where
374 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
375 Just t -> show t
376 Nothing -> "unknown"
377 attrs = values (attributes rel)
378 values m = map snd (M.toAscList m)
380data TutorialDOperatorResult = QuitResult |
381 DisplayResult String |
382 DisplayErrorResult String |
383 QuietSuccessResult |
384 NoActionResult --refactor to make this dead- there should be only one parser
386evalContextOp :: DatabaseContext -> ContextOperator -> TutorialDOperatorResult
387evalContextOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
388 (Right rel, _) -> DisplayResult $ showRelationAttributes rel
389 (Left err, _) -> DisplayErrorResult $ show err
391evalContextOp context (ShowRelation expr) = do
392 case runState (evalRelationalExpr expr) context of
393 (Left err, _) -> DisplayErrorResult $ show err
394 (Right rel, _) -> DisplayResult $ showRelation rel
396evalContextOp context (ShowConstraint name) = do
397 DisplayResult $ show filteredDeps
398 where
399 deps = inclusionDependencies context
400 filteredDeps = case name of
401 "" -> deps
402 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
404evalContextOp context (ShowPlan dbExpr) = do
405 DisplayResult $ show plan
406 where
407 plan = evalState (applyStaticDatabaseOptimization dbExpr) context
409evalContextOp context (Quit) = QuitResult
411-- returns the new "current" transaction, updated graph, and tutorial d result
412-- the current transaction is not part of the transaction graph until it is committed
413evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> GraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
415--affects only disconncted transaction
416evalGraphOp newUUID trans graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
417 Left err -> Left err
418 Right parentTrans -> Right (newTrans, graph, QuietSuccessResult)
419 where
420 newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
422-- switch from one head to another
423-- affects only disconnectedtransaction
424evalGraphOp newUUID currentTransaction graph (JumpToHead headName) =
425 case transactionForHead headName graph of
426 Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in
427 Right (disconnectedTrans, graph, QuietSuccessResult)
428 Nothing -> Left $ NoSuchHeadNameError headName
429-- add new head pointing to branchPoint
430-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
431-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
432 {-
433evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
434 Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
435 Just parentTrans -> case addBranch newBranchName parentTrans graph of
436 Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
437 Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
438 where
439 newDiscon = DisconnectedTransaction (transactionUUID parentTrans) disconContext
440-}
442-- create a new commit and add it to the heads
443-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
444evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
445 Left err -> Left err
446 Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
447 Left err -> Left err
448 Right (newTrans, newGraph) -> Right (newDiscon, newGraph, QuietSuccessResult)
449 where
450 newDiscon = DisconnectedTransaction newUUID disconContext
452-- add the disconnected transaction to the graph
453-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
454evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of
455 Left err -> Left err
456 Right parentTransaction -> case headNameForTransaction parentTransaction graph of
457 Nothing -> Left $ TransactionIsNotAHeadError parentUUID
458 Just headName -> case maybeUpdatedGraph of
459 Left err-> Left err
460 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph, QuietSuccessResult)
461 where
462 newDisconnectedTrans = newDisconnectedTransaction newTransUUID context
463 maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph
465-- refresh the disconnected transaction, return the same graph
466evalGraphOp _ discon@(DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of
467 Left err -> Left err
468 Right parentTransaction -> Right (newDiscon, graph, QuietSuccessResult)
469 where
470 newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)
472--display transaction graph as relation
473evalGraphOp _ discon graph ShowGraph = do
474 graphStr <- graphAsRelation discon graph
475 return (discon, graph, DisplayResult $ showRelation graphStr)
477--shouldn't this be Either RelationalError DatabaseContext?
478interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
479interpret context tutdstring = case parseString tutdstring of
480 Left err -> (Just err, context)
481 Right parsed -> runState (evaluator parsed) context
482 where
483 evaluator expr = do
484 context <- get
485 optExpr <- applyStaticDatabaseOptimization expr
486 --case optExpr of
487 case optExpr of
488 Left err -> return $ Just err
489 Right optExprA -> evalContextExpr optExprA
491--no optimization
492interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
493interpretNO context tutdstring = case parseString tutdstring of
494 Left err -> (Just err, context)
495 Right parsed -> runState (evalContextExpr parsed) context
498-- for interpreter-specific operations
499interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
500interpretOps newUUID trans@(DisconnectedTransaction parentUUID context) transGraph instring = case parse interpreterOps "" instring of
501 Left err -> (trans, transGraph, NoActionResult)
502 Right ops -> case ops of
503 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
504 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
505 Left err -> (trans, transGraph, DisplayErrorResult $ show err)
506 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
508promptText :: DisconnectedTransaction -> TransactionGraph -> String
509promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "
510 where
511 transInfo = case transactionForUUID parentUUID graph of
512 Left err -> "unknown"
513 Right parentTrans -> case headNameForTransaction parentTrans graph of
514 Nothing -> show $ transactionUUID parentTrans
515 Just headName -> headName
517reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()
518reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentContext) graph = do
519 homeDirectory <- getHomeDirectory
520 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
522 maybeLine <- runInputT settings $ getInputLine (promptText currentTransaction graph)
524 let roloop = reprLoop currentTransaction graph
525 case maybeLine of
526 Nothing -> return ()
527 Just line -> do
528 newUUID <- nextRandom
529 case interpretOps newUUID currentTransaction graph line of
530 (_, _, QuitResult) -> return ()
531 (_, _, DisplayErrorResult err) -> hPutStrLn stderr ("ERR: " ++ err) >> roloop
532 (updatedTrans, updatedGraph, DisplayResult out) -> do
533 putStrLn out
534 reprLoop updatedTrans updatedGraph
535 (updatedTrans, updatedGraph, QuietSuccessResult) -> do
536 putStrLn "Done."
537 reprLoop updatedTrans updatedGraph
538 (_, _, NoActionResult) -> do
539 let (value, contextup) = interpret currentContext line
540 let updatedTransaction = DisconnectedTransaction currentParentUUID contextup
541 case value of
542 Nothing -> reprLoop updatedTransaction graph
543 Just err -> do
544 hPutStrLn stderr ("ERR:" ++ show err)
545 reprLoop currentTransaction graph
547restrictionPredicateP :: Parser RestrictionPredicateExpr
548restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
549 where
550 predicateOperators = [
551 [Prefix (reservedOp "not" >> return NotPredicate)],
552 [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
553 [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
554 ]
555 predicateTerm = parens restrictionPredicateP
556 <|> try restrictionAttributeEqualityP
557 <|> try relationalBooleanExpr
560relationalBooleanExpr :: Parser RestrictionPredicateExpr
561relationalBooleanExpr = do
562 relexpr <- relExpr
563 return $ RelationalExprPredicate relexpr
565restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
566restrictionAttributeEqualityP = do
567 attributeName <- identifier
568 reservedOp "="
569 atom <- stringAtomP <|> intAtomP
570 return $ AttributeEqualityPredicate attributeName atom
572quotedChar = noneOf "\""
573 <|> try (string "\"\"" >> return '"')
575stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
577intAtomP = do
578 intstr <- many digit
579 return $ IntAtom (read intstr)
581--used by :dumpGraph
582displayTransactionGraph :: TransactionGraph -> String
583displayTransactionGraph (TransactionGraph heads transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet