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