git.iko.soy/project-m36
on b2fbc13 help sign in
project-m36/TutorialD/Interpreter/Base.hs
93 lines 3.1 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module TutorialD.Interpreter.Base where
3import Text.Parsec
4import Text.Parsec.String
5import qualified Text.Parsec.Token as Token
6import Text.Parsec.Language
7import ProjectM36.Base
8import qualified Data.Text as T
9import qualified Data.List as L
10import qualified Data.Vector as V
11import qualified Data.Text.IO as TIO
12import System.IO
13import Control.Applicative ((<*),(*>))
15lexer :: Token.TokenParser ()
16lexer = Token.makeTokenParser tutD
17 where tutD = emptyDef {
18 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
19 Token.reservedNames = [],
20 Token.identStart = letter <|> char '_',
21 Token.opLetter = oneOf ":!#$%&*+./<=>?\\^|-~", -- remove "@" so it can be used as attribute marker without spaces
22 Token.identLetter = alphaNum <|> char '_' <|> char '#'} -- # needed for Date examples
24parens :: Parser a -> Parser a
25parens = Token.parens lexer
27reservedOp :: String -> Parser ()
28reservedOp = Token.reservedOp lexer
30reserved :: String -> Parser ()
31reserved = Token.reserved lexer
33braces :: Parser a -> Parser a
34braces = Token.braces lexer
36identifier :: Parser String
37identifier = Token.identifier lexer
39comma :: Parser String
40comma = Token.comma lexer
42semi :: Parser String
43semi = Token.semi lexer
45whiteSpace :: Parser ()
46whiteSpace = Token.whiteSpace lexer
48integer :: Parser Integer
49integer = Token.integer lexer
51float :: Parser Double
52float = Token.float lexer
54atomTypeToTutDType :: AtomType -> Maybe T.Text
55atomTypeToTutDType atomType = case atomType of
56 StringAtomType -> Just "char"
57 IntAtomType -> Just "int"
58 DateTimeAtomType -> Just "datetime"
59 DoubleAtomType -> Just "double"
60 DateAtomType -> Just "date"
61 RelationAtomType attrs -> Just $ "relation" `T.append` showRelationAttributes attrs
62 _ -> Nothing
64showRelationAttributes :: Attributes -> T.Text
65showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrsL) `T.append` "}"
66 where
67 showAttribute (Attribute name atomType) = name `T.append` " " `T.append` case atomTypeToTutDType atomType of
68 Just t -> t
69 Nothing -> "unknown"
70 attrsL = V.toList attrs
72data TutorialDOperatorResult = QuitResult |
73 DisplayResult StringType |
74 DisplayIOResult (IO ()) |
75 DisplayErrorResult StringType |
76 QuietSuccessResult
78type TransactionGraphWasUpdated = Bool
80displayOpResult :: TutorialDOperatorResult -> IO ()
81displayOpResult QuitResult = return ()
82displayOpResult (DisplayResult out) = TIO.putStrLn out
83displayOpResult (DisplayIOResult ioout) = ioout
84displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " `T.append` err)
85displayOpResult QuietSuccessResult = return ()
87quotedChar :: Parser Char
88quotedChar = noneOf "\""
89 <|> try (string "\"\"" >> return '"')
91quotedString :: Parser String
92quotedString = string "\"" *> many quotedChar <* string "\""