git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/bin/TutorialD/Interpreter/Base.hs
215 lines 6.6 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
38import Data.Monoid
39import qualified Data.UUID as U
40import Control.Monad.Random
41import Data.List.NonEmpty as NE
42import Data.Time.Clock
43import Data.Time.Format
44import Control.Monad (void)
46displayOpResult :: TutorialDOperatorResult -> IO ()
47displayOpResult QuitResult = return ()
48displayOpResult (DisplayResult out) = TIO.putStrLn out
49displayOpResult (DisplayIOResult ioout) = ioout
50displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in
51 outputf stderr ("ERR: " <> err)
52displayOpResult QuietSuccessResult = return ()
53displayOpResult (DisplayRelationResult rel) = do
54 gen <- newStdGen
55 let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen
56 TIO.putStrLn (showRelation randomlySortedRel)
57displayOpResult (DisplayParseErrorResult mPromptLength err) = do
58 let errString = T.pack (parseErrorPretty err)
59 errorIndent = unPos (sourceColumn (NE.head (errorPos err)))
60 pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^"
61 maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength
62 TIO.putStr ("ERR:" <> errString)
63displayOpResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame)
65#if MIN_VERSION_megaparsec(6,0,0)
66type Parser = Parsec Void Text
67type ParseStr = Text
68#else
69type ParseStr = String
70#endif
72spaceConsumer :: Parser ()
73spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")
75opChar :: Parser Char
76opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces
78reserved :: ParseStr -> Parser ()
79reserved word = try (string word *> notFollowedBy opChar *> spaceConsumer)
81reservedOp :: ParseStr -> Parser ()
82reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer)
84parens :: Parser a -> Parser a
85parens = between (symbol "(") (symbol ")")
87braces :: Parser a -> Parser a
88braces = between (symbol "{") (symbol "}")
90identifier :: Parser Text
91identifier = do
92 istart <- letterChar <|> char '_'
93 irest <- many (alphaNumChar <|> char '_' <|> char '#')
94 spaceConsumer
95 pure (pack (istart:irest))
97symbol :: ParseStr -> Parser Text
98#if MIN_VERSION_megaparsec(6,0,0)
99symbol sym = Lex.symbol spaceConsumer sym
100#else
101symbol sym = pack <$> Lex.symbol spaceConsumer sym
102#endif
104comma :: Parser Text
105comma = symbol ","
107pipe :: Parser Text
108pipe = symbol "|"
110quote :: Parser Text
111quote = symbol "\""
113tripleQuote :: Parser Text
114tripleQuote = symbol "\"\"\""
116arrow :: Parser Text
117arrow = symbol "->"
119semi :: Parser Text
120semi = symbol ";"
122integer :: Parser Integer
123#if MIN_VERSION_megaparsec(6,0,0)
124integer = Lex.signed spaceConsumer Lex.decimal
125#else
126integer = Lex.signed spaceConsumer Lex.integer
127#endif
129natural :: Parser Integer
130#if MIN_VERSION_megaparsec(6,0,0)
131natural = Lex.decimal <* spaceConsumer
132#else
133natural = Lex.integer <* spaceConsumer
134#endif
136float :: Parser Double
137float = Lex.float
139capitalizedIdentifier :: Parser Text
140capitalizedIdentifier = do
141 fletter <- upperChar
142 restOfIdentifier_ fletter
144restOfIdentifier_ :: Char -> Parser Text
145restOfIdentifier_ fletter = do
146 rest <- option "" identifier
147 spaceConsumer
148 pure (T.cons fletter rest)
150uncapitalizedIdentifier :: Parser Text
151uncapitalizedIdentifier = do
152 fletter <- lowerChar
153 restOfIdentifier_ fletter
155showRelationAttributes :: Attributes -> Text
156showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"
157 where
158 showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType
159 attrsL = V.toList attrs
161type PromptLength = Int
163#if MIN_VERSION_megaparsec(6,0,0)
164type ParserError = ParseError Char Void
165#else
166type ParserError = ParseError Char Dec
167#endif
169data TutorialDOperatorResult = QuitResult |
170 DisplayResult StringType |
171 DisplayIOResult (IO ()) |
172 DisplayRelationResult Relation |
173 DisplayDataFrameResult DataFrame |
174 DisplayErrorResult StringType |
175 DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text
176 QuietSuccessResult
177 deriving (Generic)
179type TransactionGraphWasUpdated = Bool
181--allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying
182tripleQuotedString :: Parser Text
183tripleQuotedString = do
184 _ <- tripleQuote
185 pack <$> manyTill anyChar (try (tripleQuote >> notFollowedBy quote))
187normalQuotedString :: Parser Text
188normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)
190quotedString :: Parser Text
191quotedString = try tripleQuotedString <|> normalQuotedString
193uuidP :: Parser U.UUID
194uuidP = do
195 uuidStart <- count 8 hexDigitChar
196 _ <- char '-' -- min 28 with no dashes, maximum 4 dashes
197 uuidMid1 <- count 4 hexDigitChar
198 _ <- char '-'
199 uuidMid2 <- count 4 hexDigitChar
200 _ <- char '-'
201 uuidMid3 <- count 4 hexDigitChar
202 _ <- char '-'
203 uuidEnd <- count 12 hexDigitChar
204 let uuidStr = L.intercalate "-" [uuidStart, uuidMid1, uuidMid2, uuidMid3, uuidEnd]
205 case U.fromString uuidStr of
206 Nothing -> fail "Invalid uuid string"
207 Just uuid -> return uuid
209utcTimeP :: Parser UTCTime
210utcTimeP = do
211 timeStr <- quotedString
212 case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of
213 Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\""
214 Just stamp -> pure stamp