git.iko.soy/project-m36
on 2fbb67a help sign in
project-m36/src/bin/TutorialD/Interpreter/Base.hs
229 lines 7.1 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__ <= 802
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
53displayOpResult :: TutorialDOperatorResult -> IO ()
54displayOpResult QuitResult = return ()
55displayOpResult (DisplayResult out) = TIO.putStrLn out
56displayOpResult (DisplayIOResult ioout) = ioout
57displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in
58 outputf stderr ("ERR: " <> err)
59displayOpResult QuietSuccessResult = return ()
60displayOpResult (DisplayRelationResult rel) = do
61 gen <- newStdGen
62 let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen
63 TIO.putStrLn (showRelation randomlySortedRel)
64displayOpResult (DisplayParseErrorResult mPromptLength err) = do
65#if MIN_VERSION_megaparsec(7,0,0)
66 let errorIndent = errorOffset . NE.head . bundleErrors $ err
67 errString = T.pack (parseErrorPretty . NE.head . bundleErrors $ err)
68#else
69 let errorIndent = unPos (sourceColumn (NE.head (errorPos err)))
70 errString = T.pack (parseErrorPretty err)
71#endif
72 pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^"
73 maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength
74 TIO.putStr ("ERR:" <> errString)
75displayOpResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame)
77#if MIN_VERSION_megaparsec(6,0,0)
78type Parser = Parsec Void Text
79type ParseStr = Text
80#else
81type ParseStr = String
82#endif
84spaceConsumer :: Parser ()
85spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")
87opChar :: Parser Char
88opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces
90reserved :: ParseStr -> Parser ()
91reserved word = try (string word *> notFollowedBy opChar *> spaceConsumer)
93reservedOp :: ParseStr -> Parser ()
94reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer)
96parens :: Parser a -> Parser a
97parens = between (symbol "(") (symbol ")")
99braces :: Parser a -> Parser a
100braces = between (symbol "{") (symbol "}")
102identifier :: Parser Text
103identifier = do
104 istart <- letterChar <|> char '_'
105 irest <- many (alphaNumChar <|> char '_' <|> char '#')
106 spaceConsumer
107 pure (pack (istart:irest))
109symbol :: ParseStr -> Parser Text
110#if MIN_VERSION_megaparsec(6,0,0)
111symbol sym = Lex.symbol spaceConsumer sym
112#else
113symbol sym = pack <$> Lex.symbol spaceConsumer sym
114#endif
116comma :: Parser Text
117comma = symbol ","
119pipe :: Parser Text
120pipe = symbol "|"
122quote :: Parser Text
123quote = symbol "\""
125tripleQuote :: Parser Text
126tripleQuote = symbol "\"\"\""
128arrow :: Parser Text
129arrow = symbol "->"
131semi :: Parser Text
132semi = symbol ";"
134integer :: Parser Integer
135#if MIN_VERSION_megaparsec(6,0,0)
136integer = Lex.signed spaceConsumer Lex.decimal
137#else
138integer = Lex.signed spaceConsumer Lex.integer
139#endif
141natural :: Parser Integer
142#if MIN_VERSION_megaparsec(6,0,0)
143natural = Lex.decimal <* spaceConsumer
144#else
145natural = Lex.integer <* spaceConsumer
146#endif
148float :: Parser Double
149float = Lex.float
151capitalizedIdentifier :: Parser Text
152capitalizedIdentifier = do
153 fletter <- upperChar
154 restOfIdentifier_ fletter
156restOfIdentifier_ :: Char -> Parser Text
157restOfIdentifier_ fletter = do
158 rest <- option "" identifier
159 spaceConsumer
160 pure (T.cons fletter rest)
162uncapitalizedIdentifier :: Parser Text
163uncapitalizedIdentifier = do
164 fletter <- lowerChar
165 restOfIdentifier_ fletter
167showRelationAttributes :: Attributes -> Text
168showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"
169 where
170 showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType
171 attrsL = V.toList attrs
173type PromptLength = Int
175#if MIN_VERSION_megaparsec(7,0,0)
176type ParserError = ParseErrorBundle Text Void
177#elif MIN_VERSION_megaparsec(6,0,0)
178type ParserError = ParseError Char Void
179#else
180type ParserError = ParseError Char Dec
181#endif
183data TutorialDOperatorResult = QuitResult |
184 DisplayResult StringType |
185 DisplayIOResult (IO ()) |
186 DisplayRelationResult Relation |
187 DisplayDataFrameResult DataFrame |
188 DisplayErrorResult StringType |
189 DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text
190 QuietSuccessResult
191 deriving (Generic)
193type TransactionGraphWasUpdated = Bool
195--allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying
196tripleQuotedString :: Parser Text
197tripleQuotedString = do
198 _ <- tripleQuote
199 pack <$> manyTill anySingle (try (tripleQuote >> notFollowedBy quote))
201normalQuotedString :: Parser Text
202normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)
204quotedString :: Parser Text
205quotedString = try tripleQuotedString <|> normalQuotedString
207uuidP :: Parser U.UUID
208uuidP = do
209 uuidStart <- count 8 hexDigitChar
210 _ <- char '-' -- min 28 with no dashes, maximum 4 dashes
211 uuidMid1 <- count 4 hexDigitChar
212 _ <- char '-'
213 uuidMid2 <- count 4 hexDigitChar
214 _ <- char '-'
215 uuidMid3 <- count 4 hexDigitChar
216 _ <- char '-'
217 uuidEnd <- count 12 hexDigitChar
218 let uuidStr = L.intercalate "-" [uuidStart, uuidMid1, uuidMid2, uuidMid3, uuidEnd]
219 case U.fromString uuidStr of
220 Nothing -> fail "Invalid uuid string"
221 Just uuid -> return uuid
223utcTimeP :: Parser UTCTime
224utcTimeP = do
225 timeStr <- quotedString
226 case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of
227 Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\""
228 Just stamp' -> pure stamp'