git.iko.soy/project-m36
on 69ff6cd help sign in
project-m36/src/bin/TutorialD/Interpreter/Base.hs
225 lines 6.9 kB history raw
1{-# LANGUAGE DeriveGeneric, CPP #-}
2module TutorialD.Interpreter.Base (
3 module TutorialD.Interpreter.Base,
4 module Text.Megaparsec,
5#if MIN_VERSION_megaparsec(6,0,0)
6 module Text.Megaparsec.Char,
7 module Control.Applicative
8#else
9 module Text.Megaparsec.Text
10#endif
11 )
12 where
13import ProjectM36.Base
14import ProjectM36.AtomType
15import ProjectM36.Relation
16import ProjectM36.DataFrame
18#if MIN_VERSION_megaparsec(6,0,0)
19import Text.Megaparsec.Char
20import qualified Text.Megaparsec.Char.Lexer as Lex
21import Text.Megaparsec
22import Data.Void
23import Control.Applicative hiding (many, some)
24#else
25import Text.Megaparsec.Text
26import qualified Text.Megaparsec.Lexer as Lex
27#endif
29import Data.Text hiding (count)
30import System.Random
31import qualified Data.Text as T
32import qualified Data.List as L
33import qualified Data.Vector as V
34import qualified Data.Text.IO as TIO
35import System.IO
36import ProjectM36.Relation.Show.Term
37import GHC.Generics
38#if __GLASGOW_HASKELL__ < 804
39import Data.Monoid
40#endif
41import qualified Data.UUID as U
42import Control.Monad.Random
43import Data.List.NonEmpty as NE
44import Data.Time.Clock
45import Data.Time.Format
46import Control.Monad (void)
48#if !MIN_VERSION_megaparsec(7,0,0)
49anySingle :: Parsec Void Text (Token Text)
50anySingle = anyChar
51#endif
54displayOpResult :: TutorialDOperatorResult -> IO ()
55displayOpResult QuitResult = return ()
56displayOpResult (DisplayResult out) = TIO.putStrLn out
57displayOpResult (DisplayIOResult ioout) = ioout
58displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in
59 outputf stderr ("ERR: " <> err)
60displayOpResult QuietSuccessResult = return ()
61displayOpResult (DisplayRelationResult rel) = do
62 gen <- newStdGen
63 let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen
64 TIO.putStrLn (showRelation randomlySortedRel)
65displayOpResult (DisplayParseErrorResult mPromptLength err) = do
66#if MIN_VERSION_megaparsec(7,0,0)
67 let errorIndent = errorOffset . NE.head . bundleErrors $ err
68 errString = T.pack (parseErrorPretty . NE.head . bundleErrors $ err)
69#else
70 let errorIndent = unPos (sourceColumn (NE.head (errorPos err)))
71 errString = T.pack (parseErrorPretty err)
72#endif
73 pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^"
74 maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength
75 TIO.putStr ("ERR:" <> errString)
76displayOpResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame)
78#if MIN_VERSION_megaparsec(6,0,0)
79type Parser = Parsec Void Text
80type ParseStr = Text
81#else
82type ParseStr = String
83#endif
85spaceConsumer :: Parser ()
86spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")
88opChar :: Parser Char
89opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces
91reserved :: ParseStr -> Parser ()
92reserved word = try (string word *> notFollowedBy opChar *> spaceConsumer)
94reservedOp :: ParseStr -> Parser ()
95reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer)
97parens :: Parser a -> Parser a
98parens = between (symbol "(") (symbol ")")
100braces :: Parser a -> Parser a
101braces = between (symbol "{") (symbol "}")
103identifier :: Parser Text
104identifier = do
105 istart <- letterChar <|> char '_'
106 identifierRemainder istart
108identifierRemainder :: Char -> Parser Text
109identifierRemainder c = do
110 rest <- many (alphaNumChar <|> char '_' <|> char '#')
111 spaceConsumer
112 pure (pack (c:rest))
114symbol :: ParseStr -> Parser Text
115#if MIN_VERSION_megaparsec(6,0,0)
116symbol sym = Lex.symbol spaceConsumer sym
117#else
118symbol sym = pack <$> Lex.symbol spaceConsumer sym
119#endif
121comma :: Parser Text
122comma = symbol ","
124pipe :: Parser Text
125pipe = symbol "|"
127quote :: Parser Text
128quote = symbol "\""
130tripleQuote :: Parser Text
131tripleQuote = symbol "\"\"\""
133arrow :: Parser Text
134arrow = symbol "->"
136semi :: Parser Text
137semi = symbol ";"
139integer :: Parser Integer
140#if MIN_VERSION_megaparsec(6,0,0)
141integer = Lex.signed spaceConsumer Lex.decimal
142#else
143integer = Lex.signed spaceConsumer Lex.integer
144#endif
146natural :: Parser Integer
147#if MIN_VERSION_megaparsec(6,0,0)
148natural = Lex.decimal <* spaceConsumer
149#else
150natural = Lex.integer <* spaceConsumer
151#endif
153float :: Parser Double
154float = Lex.float
156capitalizedIdentifier :: Parser Text
157capitalizedIdentifier =
158 upperChar >>= identifierRemainder
160uncapitalizedIdentifier :: Parser Text
161uncapitalizedIdentifier =
162 lowerChar >>= identifierRemainder
164showRelationAttributes :: Attributes -> Text
165showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"
166 where
167 showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType
168 attrsL = V.toList attrs
170type PromptLength = Int
172#if MIN_VERSION_megaparsec(7,0,0)
173type ParserError = ParseErrorBundle T.Text Void
174#elif MIN_VERSION_megaparsec(6,0,0)
175type ParserError = ParseError Char Void
176#else
177type ParserError = ParseError Char Dec
178#endif
180data TutorialDOperatorResult = QuitResult |
181 DisplayResult StringType |
182 DisplayIOResult (IO ()) |
183 DisplayRelationResult Relation |
184 DisplayDataFrameResult DataFrame |
185 DisplayErrorResult StringType |
186 DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text
187 QuietSuccessResult
188 deriving (Generic)
190type TransactionGraphWasUpdated = Bool
192--allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying
193tripleQuotedString :: Parser Text
194tripleQuotedString = do
195 _ <- tripleQuote
196 pack <$> manyTill anySingle (try (tripleQuote >> notFollowedBy quote))
198normalQuotedString :: Parser Text
199normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)
201quotedString :: Parser Text
202quotedString = try tripleQuotedString <|> normalQuotedString
204uuidP :: Parser U.UUID
205uuidP = do
206 uuidStart <- count 8 hexDigitChar
207 _ <- char '-' -- min 28 with no dashes, maximum 4 dashes
208 uuidMid1 <- count 4 hexDigitChar
209 _ <- char '-'
210 uuidMid2 <- count 4 hexDigitChar
211 _ <- char '-'
212 uuidMid3 <- count 4 hexDigitChar
213 _ <- char '-'
214 uuidEnd <- count 12 hexDigitChar
215 let uuidStr = L.intercalate "-" [uuidStart, uuidMid1, uuidMid2, uuidMid3, uuidEnd]
216 case U.fromString uuidStr of
217 Nothing -> fail "Invalid uuid string"
218 Just uuid -> return uuid
220utcTimeP :: Parser UTCTime
221utcTimeP = do
222 timeStr <- quotedString
223 case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of
224 Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\""
225 Just stamp -> pure stamp