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