git.iko.soy/project-m36
on da528b7 help sign in
project-m36/TutorialD/Interpreter.hs
100 lines 4.1 kB history raw
1{-# LANGUAGE GADTs,OverloadedStrings #-}
2module TutorialD.Interpreter where
3import TutorialD.Interpreter.Base
4import TutorialD.Interpreter.RODatabaseContextOperator
5import TutorialD.Interpreter.DatabaseExpr
6import TutorialD.Interpreter.TransactionGraphOperator
7import ProjectM36.Base
8import ProjectM36.Relation.Show.Term
9import ProjectM36.TransactionGraph
10import ProjectM36.Client
11import Text.Parsec
12import Text.Parsec.String
13import Control.Monad.State
14import System.Console.Haskeline
15import System.Directory (getHomeDirectory)
16import qualified Data.Text as T
17import Control.Applicative ((<*))
19{-
20context ops are read-only operations which only operate on the database context (relvars and constraints)
21database ops are read-write operations which change the database context (such as relvar assignment)
22graph ops are read-write operations which change the transaction graph
23-}
24data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |
25 DatabaseExprOp DatabaseExpr |
26 GraphOp TransactionGraphOperator |
27 ROGraphOp ROTransactionGraphOperator
29interpreterParserP :: Parser ParsedOperation
30interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>
31 liftM GraphOp (transactionGraphOpP <* eof) <|>
32 liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>
33 liftM DatabaseExprOp (databaseExprOpP <* eof)
35promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
36promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
37 where
38 transInfo = case transactionForUUID parentUUID graph of
39 Left _ -> "unknown"
40 Right parentTrans -> case headNameForTransaction parentTrans graph of
41 Nothing -> T.pack (show $ transactionUUID parentTrans)
42 Just headName -> headName
44parseTutorialD :: Connection -> String -> Either ParseError ParsedOperation
45parseTutorialD (InProcessConnection _ _) inputString = parse interpreterParserP "" inputString
47--execute the operation and display result
48evalTutorialD :: Connection -> ParsedOperation -> IO (TutorialDOperatorResult)
49evalTutorialD conn expr = case expr of
51 --this does not pass through the ProjectM36.Client library because the operations
52 --are specific to the interpreter, though some operations may be of general use in the future
53 (RODatabaseContextOp execOp) -> do
54 (DisconnectedTransaction _ context) <- disconnectedTransaction conn
55 return $ evalRODatabaseContextOp context execOp
57 (DatabaseExprOp execOp) -> do
58 maybeErr <- executeDatabaseContextExpr conn execOp
59 case maybeErr of
60 Just err -> barf err
61 Nothing -> return $ QuietSuccessResult
63 (GraphOp execOp) -> do
64 maybeErr <- executeGraphExpr conn execOp
65 case maybeErr of
66 Just err -> barf err
67 Nothing -> return $ QuietSuccessResult
69 (ROGraphOp execOp) -> do
70 discon <- disconnectedTransaction conn
71 graph <- transactionGraph conn
72 case evalROGraphOp discon graph execOp of
73 Left err -> barf err
74 Right rel -> return $ DisplayResult $ showRelation rel
76 where
77 barf err = return $ DisplayErrorResult (T.pack (show err))
79data InterpreterConfig = InterpreterConfig {
80 persistenceStrategy :: PersistenceStrategy
81 }
83reprLoop :: InterpreterConfig -> Connection -> IO ()
84reprLoop config conn = do
85 homeDirectory <- getHomeDirectory
86 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
87 discon <- disconnectedTransaction conn
88 graph <- transactionGraph conn
89 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText discon graph))
90 let roloop = reprLoop config conn
91 case maybeLine of
92 Nothing -> return ()
93 Just line -> do
94 case parseTutorialD conn line of
95 Left err -> do
96 displayOpResult $ DisplayErrorResult (T.pack (show err))
97 roloop
98 Right parsed -> do
99 evald <- evalTutorialD conn parsed
100 displayOpResult evald