git.iko.soy/project-m36
on 047b40c help sign in
project-m36/src/bin/TutorialD/Interpreter/Base.hs
170 lines 5.5 kB history raw
1{-# LANGUAGE DeriveGeneric, CPP #-}
2module TutorialD.Interpreter.Base where
3import ProjectM36.Base
4import ProjectM36.AtomType
5import ProjectM36.Relation
7import Text.Megaparsec
8import Text.Megaparsec.Text
9import qualified Text.Megaparsec.Lexer as Lex
10import Data.Text hiding (count)
11import System.Random
12import qualified Data.Text as T
13import qualified Data.List as L
14import qualified Data.Vector as V
15import qualified Data.Text.IO as TIO
16import System.IO
17import ProjectM36.Relation.Show.Term
18import GHC.Generics
19import Data.Monoid
20import qualified Data.UUID as U
21import Control.Monad.Random
22import Data.List.NonEmpty as NE
23import Data.Time.Clock
24import Data.Time.Format
26displayOpResult :: TutorialDOperatorResult -> IO ()
27displayOpResult QuitResult = return ()
28displayOpResult (DisplayResult out) = TIO.putStrLn out
29displayOpResult (DisplayIOResult ioout) = ioout
30displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in
31 outputf stderr ("ERR: " <> err)
32displayOpResult QuietSuccessResult = return ()
33displayOpResult (DisplayRelationResult rel) = do
34 gen <- newStdGen
35 let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen
36 TIO.putStrLn (showRelation randomlySortedRel)
37displayOpResult (DisplayParseErrorResult mPromptLength err) = do
38 let errString = T.pack (parseErrorPretty err)
39 errorIndent = unPos (sourceColumn (NE.head (errorPos err)))
40 pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^"
41 maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength
42 TIO.putStr ("ERR:" <> errString)
44spaceConsumer :: Parser ()
45spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")
47opChar :: Parser Char
48opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces
50reserved :: String -> Parser ()
51reserved word = try (string word *> notFollowedBy opChar *> spaceConsumer)
53reservedOp :: String -> Parser ()
54reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer)
56parens :: Parser a -> Parser a
57parens = between (symbol "(") (symbol ")")
59braces :: Parser a -> Parser a
60braces = between (symbol "{") (symbol "}")
62identifier :: Parser Text
63identifier = do
64 istart <- letterChar <|> char '_'
65 irest <- many (alphaNumChar <|> char '_' <|> char '#')
66 spaceConsumer
67 pure (pack (istart:irest))
69symbol :: String -> Parser Text
70symbol sym = pack <$> Lex.symbol spaceConsumer sym
72comma :: Parser Text
73comma = symbol ","
75pipe :: Parser Text
76pipe = symbol "|"
78quote :: Parser Text
79quote = symbol "\""
81tripleQuote :: Parser Text
82tripleQuote = symbol "\"\"\""
84arrow :: Parser Text
85arrow = symbol "->"
87semi :: Parser Text
88semi = symbol ";"
90{-
91whiteSpace :: Parser ()
92whiteSpace = Token.whiteSpace lexer
93-}
95integer :: Parser Integer
96integer = Lex.integer
98float :: Parser Double
99float = Lex.float
101capitalizedIdentifier :: Parser Text
102capitalizedIdentifier = do
103 fletter <- upperChar
104 restOfIdentifier_ fletter
106restOfIdentifier_ :: Char -> Parser Text
107restOfIdentifier_ fletter = do
108 rest <- option "" identifier
109 spaceConsumer
110 pure (T.cons fletter rest)
112uncapitalizedIdentifier :: Parser Text
113uncapitalizedIdentifier = do
114 fletter <- lowerChar
115 restOfIdentifier_ fletter
117showRelationAttributes :: Attributes -> Text
118showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"
119 where
120 showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType
121 attrsL = V.toList attrs
123type PromptLength = Int
125data TutorialDOperatorResult = QuitResult |
126 DisplayResult StringType |
127 DisplayIOResult (IO ()) |
128 DisplayRelationResult Relation |
129 DisplayErrorResult StringType |
130 DisplayParseErrorResult (Maybe PromptLength) (ParseError Char Dec) | -- Int refers to length of prompt text
131 QuietSuccessResult
132 deriving (Generic)
134type TransactionGraphWasUpdated = Bool
136--allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying
137tripleQuotedString :: Parser Text
138tripleQuotedString = do
139 _ <- tripleQuote
140 pack <$> manyTill anyChar (try (tripleQuote >> notFollowedBy quote))
142normalQuotedString :: Parser Text
143normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)
145quotedString :: Parser Text
146quotedString = try tripleQuotedString <|> normalQuotedString
148uuidP :: Parser U.UUID
149uuidP = do
150 uuidStart <- count 8 hexDigitChar
151 _ <- char '-' -- min 28 with no dashes, maximum 4 dashes
152 uuidMid1 <- count 4 hexDigitChar
153 _ <- char '-'
154 uuidMid2 <- count 4 hexDigitChar
155 _ <- char '-'
156 uuidMid3 <- count 4 hexDigitChar
157 _ <- char '-'
158 uuidEnd <- count 12 hexDigitChar
159 let uuidStr = L.intercalate "-" [uuidStart, uuidMid1, uuidMid2, uuidMid3, uuidEnd]
160 case U.fromString uuidStr of
161 Nothing -> fail "Invalid uuid string"
162 Just uuid -> return uuid
164utcTimeP :: Parser UTCTime
165utcTimeP = do
166 timeStr <- quotedString
167 case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of
168 Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\""
169 Just stamp -> pure stamp