@@ -1,70 +1,63 @@
11{-# LANGUAGE DeriveGeneric #-}
22module TutorialD.Interpreter.Base where
3−import Text.Parsec
4−import Text.Parsec.String
5−import qualified Text.Parsec.Token as Token
6−import Text.Parsec.Language
3+import Text.Megaparsec
4+import Text.Megaparsec.Text
5+import qualified Text.Megaparsec.Lexer as Lex
76import ProjectM36.Base
87import ProjectM36.AtomType
9−import qualified Data.Text as T
8+import Data.Text
109import qualified Data.List as L
1110import qualified Data.Vector as V
1211import qualified Data.Text.IO as TIO
1312import System.IO
1413import ProjectM36.Relation.Show.Term
1514import GHC.Generics
15+import Data.Monoid
1616
1717displayOpResult :: TutorialDOperatorResult -> IO ()
1818displayOpResult QuitResult = return ()
1919displayOpResult (DisplayResult out) = TIO.putStrLn out
2020displayOpResult (DisplayIOResult ioout) = ioout
21−displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " `T.append` err)
21+displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " <> err)
2222displayOpResult QuietSuccessResult = return ()
2323displayOpResult (DisplayRelationResult rel) = TIO.putStrLn (showRelation rel)
2424
25−lexer :: Token.TokenParser ()
26−lexer = Token.makeTokenParser tutD
27− where tutD = emptyDef {
28− Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
29− Token.reservedNames = [],
30− Token.identStart = letter <|> char '_',
31− Token.opLetter = oneOf ":!#$%&*+./<=>?\\^|-~", -- remove "@" so it can be used as attribute marker without spaces
32− Token.identLetter = alphaNum <|> char '_' <|> char '#'} -- # needed for Date examples
33−
25+spaceConsumer = space spaceChar (skipLineComment "--") (skipBlockComment "{-" "-}")
26+
3427parens :: Parser a -> Parser a
35−parens = Token.parens lexer
28+parens = between (symbol "(") (symbol ")")
3629
37−reservedOp :: String -> Parser ()
30+reservedOp :: Text -> Parser ()
3831reservedOp = Token.reservedOp lexer
3932
40−reserved :: String -> Parser ()
33+reserved :: Text -> Parser ()
4134reserved = Token.reserved lexer
4235
4336braces :: Parser a -> Parser a
4437braces = Token.braces lexer
4538
46−identifier :: Parser String
39+identifier :: Parser Text
4740identifier = Token.identifier lexer
4841
49−symbol :: String -> Parser String
50−symbol = Token.symbol lexer
42+symbol :: Text -> Parser Text
43+symbol = L.symbol spaceConsumer
5144
52−comma :: Parser String
45+comma :: Parser Text
5346comma = Token.comma lexer
5447
55−pipe :: Parser String
48+pipe :: Parser Text
5649pipe = Token.symbol lexer "|"
5750
58−quote :: Parser String
51+quote :: Parser Text
5952quote = Token.symbol lexer "\""
6053
61−tripleQuote :: Parser String
54+tripleQuote :: Parser Text
6255tripleQuote = Token.symbol lexer "\"\"\""
6356
64−arrow :: Parser String
57+arrow :: Parser Text
6558arrow = Token.symbol lexer "->"
6659
67−semi :: Parser String
60+semi :: Parser Text
6861semi = Token.semi lexer
6962
7063whiteSpace :: Parser ()
@@ -76,24 +69,24 @@ integer = Token.integer lexer
7669float :: Parser Double
7770float = Token.float lexer
7871
79−capitalizedIdentifier :: Parser String
72+capitalizedIdentifier :: Parser Text
8073capitalizedIdentifier = do
8174 fletter <- upper
8275 rest <- option "" identifier
8376 spaces
8477 pure $ fletter:rest
8578
86−uncapitalizedIdentifier :: Parser String
79+uncapitalizedIdentifier :: Parser Text
8780uncapitalizedIdentifier = do
8881 fletter <- lower
8982 rest <- option "" identifier
9083 spaces
9184 pure (fletter:rest)
9285
93−showRelationAttributes :: Attributes -> T.Text
94−showRelationAttributes attrs = "{" `T.append` T.concat (L.intersperse ", " $ map showAttribute attrsL) `T.append` "}"
86+showRelationAttributes :: Attributes -> Text
87+showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ map showAttribute attrsL) <> "}"
9588 where
96− showAttribute (Attribute name atomType) = name `T.append` " " `T.append` prettyAtomType atomType
89+ showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType
9790 attrsL = V.toList attrs
9891
9992data TutorialDOperatorResult = QuitResult |
@@ -106,15 +99,7 @@ data TutorialDOperatorResult = QuitResult |
10699
107100type TransactionGraphWasUpdated = Bool
108101
109−{-
110−quotedChar :: Parser Char
111−quotedChar = noneOf "\""
112− <|> try (string "\"\"" >> return '"')
113−
114−quotedString :: Parser String
115−quotedString = string "\"" *> many quotedChar <* string "\"" <* whiteSpace
116−-}
117−escapedString :: Parser String
102+escapedString :: Parser Text
118103escapedString = do
119104 _ <- char '\\'
120105 let lookupAssoc = [('n',"\n"), ('\"',"\""), ('\\', "\\")]
@@ -127,21 +112,21 @@ escapedString = do
127112nonEscapedChar :: Parser Char
128113nonEscapedChar = noneOf "\\\""
129114
130−character :: Parser String
115+character :: Parser Text
131116character = fmap return nonEscapedChar <|> escapedString
132117
133118--allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying
134−tripleQuotedString :: Parser String
119+tripleQuotedString :: Parser Text
135120tripleQuotedString = do
136121 _ <- tripleQuote
137122 manyTill anyChar (try (tripleQuote >> notFollowedBy quote))
138123
139−normalQuotedString :: Parser String
124+normalQuotedString :: Parser Text
140125normalQuotedString = do
141126 _ <- quote
142127 strings <- many character
143128 _ <- quote
144129 pure (concat strings)
145130
146−quotedString :: Parser String
131+quotedString :: Parser Text
147132quotedString = try tripleQuotedString <|> normalQuotedString