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