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