git.iko.soy/project-m36
on 18de5fe help sign in
project-m36/TutorialDInterpreter.hs
547 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
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 --parentTransaction = transactionForUUID parentUUID graph
444 maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph
446-- refresh the disconnected transaction, return the same graph
447evalGraphOp _ discon@(DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of
448 Left err -> Left err
449 Right parentTransaction -> Right (newDiscon, graph, QuietSuccessResult)
450 where
451 newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)
453--display transaction graph as relation
454evalGraphOp _ discon graph ShowGraph = do
455 graphStr <- graphAsRelation discon graph
456 return (discon, graph, DisplayResult $ showRelation graphStr)
458--shouldn't this be Either RelationalError DatabaseContext?
459interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
460interpret context tutdstring = case parseString tutdstring of
461 Left err -> (Just err, context)
462 Right parsed -> runState (evalContextExpr parsed) context
464-- for interpreter-specific operations
465interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)
466interpretOps newUUID trans@(DisconnectedTransaction parentUUID context) transGraph instring = case parse interpreterOps "" instring of
467 Left err -> (trans, transGraph, NoActionResult)
468 Right ops -> case ops of
469 Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))
470 Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of
471 Left err -> (trans, transGraph, DisplayErrorResult $ show err)
472 Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)
474promptText :: DisconnectedTransaction -> TransactionGraph -> String
475promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" ++ transInfo ++ "): "
476 where
477 transInfo = case transactionForUUID parentUUID graph of
478 Left err -> "unknown"
479 Right parentTrans -> case headNameForTransaction parentTrans graph of
480 Nothing -> show $ transactionUUID parentTrans
481 Just headName -> headName
483reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()
484reprLoop currentTransaction@(DisconnectedTransaction currentParentUUID currentContext) graph = do
485 homeDirectory <- getHomeDirectory
486 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
488 maybeLine <- runInputT settings $ getInputLine (promptText currentTransaction graph)
490 let roloop = reprLoop currentTransaction graph
491 case maybeLine of
492 Nothing -> return ()
493 Just line -> do
494 newUUID <- nextRandom
495 case interpretOps newUUID currentTransaction graph line of
496 (_, _, QuitResult) -> return ()
497 (_, _, DisplayErrorResult err) -> hPutStrLn stderr ("ERR: " ++ err) >> roloop
498 (updatedTrans, updatedGraph, DisplayResult out) -> do
499 putStrLn out
500 reprLoop updatedTrans updatedGraph
501 (_, _, NoActionResult) -> do
502 let (value, contextup) = interpret currentContext line
503 let updatedTransaction = DisconnectedTransaction currentParentUUID contextup
504 case value of
505 Nothing -> reprLoop updatedTransaction graph
506 Just err -> do
507 hPutStrLn stderr ("ERR:" ++ show err)
508 reprLoop currentTransaction graph
510restrictionPredicateP :: Parser RestrictionPredicateExpr
511restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
512 where
513 predicateOperators = [
514 [Prefix (reservedOp "not" >> return NotPredicate)],
515 [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
516 [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
517 ]
518 predicateTerm = parens restrictionPredicateP
519 <|> try restrictionAttributeEqualityP
520 <|> try relationalBooleanExpr
523relationalBooleanExpr :: Parser RestrictionPredicateExpr
524relationalBooleanExpr = do
525 relexpr <- relExpr
526 return $ RelationalExprPredicate relexpr
528restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
529restrictionAttributeEqualityP = do
530 attributeName <- identifier
531 reservedOp "="
532 atom <- stringAtomP <|> intAtomP
533 return $ AttributeEqualityPredicate attributeName atom
535quotedChar = noneOf "\""
536 <|> try (string "\"\"" >> return '"')
538stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
540intAtomP = do
541 intstr <- many digit
542 return $ IntAtom (read intstr)
544--used by :dumpGraph
545displayTransactionGraph :: TransactionGraph -> String
546displayTransactionGraph (TransactionGraph heads transSet) = L.intercalate "\n" $ S.foldr (\(Transaction tUUID pUUID _ ) acc -> acc ++ [show tUUID ++ " " ++ show pUUID]) [] transSet