git.iko.soy/project-m36
on d64cdeb help sign in
project-m36/src/bin/TutorialD/Interpreter/Base.hs
171 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
25import Control.Monad (void)
27displayOpResult :: TutorialDOperatorResult -> IO ()
28displayOpResult QuitResult = return ()
29displayOpResult (DisplayResult out) = TIO.putStrLn out
30displayOpResult (DisplayIOResult ioout) = ioout
31displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in
32 outputf stderr ("ERR: " <> err)
33displayOpResult QuietSuccessResult = return ()
34displayOpResult (DisplayRelationResult rel) = do
35 gen <- newStdGen
36 let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen
37 TIO.putStrLn (showRelation randomlySortedRel)
38displayOpResult (DisplayParseErrorResult mPromptLength err) = do
39 let errString = T.pack (parseErrorPretty err)
40 errorIndent = unPos (sourceColumn (NE.head (errorPos err)))
41 pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^"
42 maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength
43 TIO.putStr ("ERR:" <> errString)
45spaceConsumer :: Parser ()
46spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")
48opChar :: Parser Char
49opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces
51reserved :: String -> Parser ()
52reserved word = try (string word *> notFollowedBy opChar *> spaceConsumer)
54reservedOp :: String -> Parser ()
55reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer)
57parens :: Parser a -> Parser a
58parens = between (symbol "(") (symbol ")")
60braces :: Parser a -> Parser a
61braces = between (symbol "{") (symbol "}")
63identifier :: Parser Text
64identifier = do
65 istart <- letterChar <|> char '_'
66 irest <- many (alphaNumChar <|> char '_' <|> char '#')
67 spaceConsumer
68 pure (pack (istart:irest))
70symbol :: String -> Parser Text
71symbol sym = pack <$> Lex.symbol spaceConsumer sym
73comma :: Parser Text
74comma = symbol ","
76pipe :: Parser Text
77pipe = symbol "|"
79quote :: Parser Text
80quote = symbol "\""
82tripleQuote :: Parser Text
83tripleQuote = symbol "\"\"\""
85arrow :: Parser Text
86arrow = symbol "->"
88semi :: Parser Text
89semi = symbol ";"
91{-
92whiteSpace :: Parser ()
93whiteSpace = Token.whiteSpace lexer
94-}
96integer :: Parser Integer
97integer = Lex.integer
99float :: Parser Double
100float = Lex.float
102capitalizedIdentifier :: Parser Text
103capitalizedIdentifier = do
104 fletter <- upperChar
105 restOfIdentifier_ fletter
107restOfIdentifier_ :: Char -> Parser Text
108restOfIdentifier_ fletter = do
109 rest <- option "" identifier
110 spaceConsumer
111 pure (T.cons fletter rest)
113uncapitalizedIdentifier :: Parser Text
114uncapitalizedIdentifier = do
115 fletter <- lowerChar
116 restOfIdentifier_ fletter
118showRelationAttributes :: Attributes -> Text
119showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"
120 where
121 showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType
122 attrsL = V.toList attrs
124type PromptLength = Int
126data TutorialDOperatorResult = QuitResult |
127 DisplayResult StringType |
128 DisplayIOResult (IO ()) |
129 DisplayRelationResult Relation |
130 DisplayErrorResult StringType |
131 DisplayParseErrorResult (Maybe PromptLength) (ParseError Char Dec) | -- Int refers to length of prompt text
132 QuietSuccessResult
133 deriving (Generic)
135type TransactionGraphWasUpdated = Bool
137--allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying
138tripleQuotedString :: Parser Text
139tripleQuotedString = do
140 _ <- tripleQuote
141 pack <$> manyTill anyChar (try (tripleQuote >> notFollowedBy quote))
143normalQuotedString :: Parser Text
144normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)
146quotedString :: Parser Text
147quotedString = try tripleQuotedString <|> normalQuotedString
149uuidP :: Parser U.UUID
150uuidP = do
151 uuidStart <- count 8 hexDigitChar
152 _ <- char '-' -- min 28 with no dashes, maximum 4 dashes
153 uuidMid1 <- count 4 hexDigitChar
154 _ <- char '-'
155 uuidMid2 <- count 4 hexDigitChar
156 _ <- char '-'
157 uuidMid3 <- count 4 hexDigitChar
158 _ <- char '-'
159 uuidEnd <- count 12 hexDigitChar
160 let uuidStr = L.intercalate "-" [uuidStart, uuidMid1, uuidMid2, uuidMid3, uuidEnd]
161 case U.fromString uuidStr of
162 Nothing -> fail "Invalid uuid string"
163 Just uuid -> return uuid
165utcTimeP :: Parser UTCTime
166utcTimeP = do
167 timeStr <- quotedString
168 case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of
169 Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\""
170 Just stamp -> pure stamp