Lexer.hs (5876B)
1 module Lexer where 2 3 import Research 4 5 import Control.Monad (void) 6 import Data.Functor (($>)) 7 import Data.Set () 8 import Data.Void 9 import Text.Megaparsec 10 import Text.Megaparsec.Char hiding (space) 11 import Text.Megaparsec.Char.Lexer 12 13 type Lexer = Parsec Void String 14 15 tricuLexer :: Lexer [LToken] 16 tricuLexer = do 17 sc 18 header <- many $ do 19 tok <- choice 20 [ try lImport 21 , lnewline 22 ] 23 sc 24 pure tok 25 toks <- many $ do 26 tok <- choice tricuLexer' 27 sc 28 pure tok 29 sc 30 eof 31 pure (header ++ toks) 32 where 33 tricuLexer' = 34 [ try lnewline 35 , try indentMarker 36 , try dot 37 , try identifierWithHash 38 , try keywordT 39 , try identifier 40 , try namespace 41 , try integerLiteral 42 , try stringLiteral 43 , try assignAt 44 , assign 45 , atSign 46 , colon 47 , openParen 48 , closeParen 49 , openBracket 50 , closeBracket 51 , try bindArrow 52 , try arrowLeft 53 , try arrowRight 54 ] 55 56 lexTricu :: String -> [LToken] 57 lexTricu input = case runParser tricuLexer "" (insertIndentMarkers input) of 58 Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err 59 Right toks -> toks 60 61 insertIndentMarkers :: String -> String 62 insertIndentMarkers = go False False 63 where 64 marker n = '\v' : show n ++ " " 65 66 go _ _ [] = [] 67 go inString escaped (c:cs) 68 | inString = 69 c : go (not (c == '"' && not escaped)) (c == '\\' && not escaped) cs 70 | c == '"' = c : go True False cs 71 | c == '\n' = 72 let (spaces, rest) = span (== ' ') cs 73 n = length spaces 74 in if n == 0 75 then '\n' : go False False rest 76 else '\n' : marker n ++ go False False rest 77 | c == '\t' = errorWithoutStackTrace "Tabs are not allowed for indentation; use two spaces per indent level" 78 | otherwise = c : go False False cs 79 80 81 keywordT :: Lexer LToken 82 keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT 83 84 identifierWithHash :: Lexer LToken 85 identifierWithHash = do 86 first <- letterChar <|> char '_' 87 rest <- many $ letterChar 88 <|> digitChar <|> char '_' <|> char '-' <|> char '?' 89 <|> char '$' <|> char '%' 90 <|> char '\'' 91 _ <- char '#' -- Consume '#' 92 hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash 93 <?> "hash characters (alphanumeric or hyphen)" 94 95 let name = first : rest 96 let hashLen = length hashString 97 if name == "t" || name == "!result" 98 then fail "Keywords (`t`, `!result`) cannot be used with a hash suffix." 99 else if hashLen < 16 then 100 fail $ "Hash suffix for '" ++ name ++ "' must be at least 16 characters long. Got " ++ show hashLen ++ " ('" ++ hashString ++ "')." 101 else if hashLen > 64 then -- Assuming SHA256, max 64 102 fail $ "Hash suffix for '" ++ name ++ "' cannot be longer than 64 characters (SHA256). Got " ++ show hashLen ++ " ('" ++ hashString ++ "')." 103 else 104 return (LIdentifierWithHash name hashString) 105 106 identifier :: Lexer LToken 107 identifier = do 108 first <- letterChar <|> char '_' 109 rest <- many $ letterChar 110 <|> digitChar <|> char '_' <|> char '-' <|> char '?' 111 <|> char '$' <|> char '%' 112 <|> char '\'' 113 let name = first : rest 114 if name == "t" || name == "!result" 115 then fail "Keywords (`t`, `!result`) cannot be used as an identifier" 116 else return (LIdentifier name) 117 118 namespace :: Lexer LToken 119 namespace = LNamespace <$> string "!Local" 120 121 dot :: Lexer LToken 122 dot = char '.' $> LDot 123 124 lImport :: Lexer LToken 125 lImport = do 126 _ <- string "!import" 127 space1 128 LStringLiteral path <- stringLiteral 129 space1 130 name <- importAlias 131 return (LImport path name) 132 133 importAlias :: Lexer String 134 importAlias = string "!Local" <|> do 135 first <- letterChar <|> char '_' 136 rest <- many (letterChar <|> digitChar <|> char '_' <|> char '-' <|> char '?' <|> char '$' <|> char '%' <|> char '\'' <|> char '.') 137 let name = first : rest 138 if name == "t" || name == "!result" 139 then fail "Keywords (`t`, `!result`) cannot be used as an import alias" 140 else pure name 141 142 assignAt :: Lexer LToken 143 assignAt = string "=@" $> LAssignAt 144 145 assign :: Lexer LToken 146 assign = char '=' $> LAssign 147 148 atSign :: Lexer LToken 149 atSign = char '@' $> LAt 150 151 colon :: Lexer LToken 152 colon = char ':' $> LColon 153 154 openParen :: Lexer LToken 155 openParen = char '(' $> LOpenParen 156 157 closeParen :: Lexer LToken 158 closeParen = char ')' $> LCloseParen 159 160 openBracket :: Lexer LToken 161 openBracket = char '[' $> LOpenBracket 162 163 closeBracket :: Lexer LToken 164 closeBracket = char ']' $> LCloseBracket 165 166 arrowLeft :: Lexer LToken 167 arrowLeft = string "<|" $> LArrowLeft 168 169 arrowRight :: Lexer LToken 170 arrowRight = string "|>" $> LArrowRight 171 172 bindArrow :: Lexer LToken 173 bindArrow = string "<-" $> LBindArrow 174 175 lnewline :: Lexer LToken 176 lnewline = char '\n' $> LNewline 177 178 indentMarker :: Lexer LToken 179 indentMarker = do 180 void (char '\v') 181 n <- some digitChar 182 pure (LIndent (read n)) 183 184 sc :: Lexer () 185 sc = space 186 (void $ takeWhile1P (Just "space") (\c -> c == ' ' || c == '\t')) 187 (skipLineComment "--") 188 (skipBlockComment "|-" "-|") 189 190 integerLiteral :: Lexer LToken 191 integerLiteral = do 192 num <- some digitChar 193 return (LIntegerLiteral (read num)) 194 195 stringLiteral :: Lexer LToken 196 stringLiteral = do 197 void (char '"') 198 content <- manyTill Lexer.charLiteral (void (char '"')) 199 return (LStringLiteral content) 200 201 charLiteral :: Lexer Char 202 charLiteral = escapedChar <|> normalChar 203 where 204 normalChar = noneOf ['"', '\\'] 205 escapedChar = do 206 void $ char '\\' 207 c <- oneOf ['n', 't', 'r', 'f', 'b', '\\', '"', '\''] 208 return $ case c of 209 'n' -> '\n' 210 't' -> '\t' 211 'r' -> '\r' 212 'f' -> '\f' 213 'b' -> '\b' 214 '\\' -> '\\' 215 '"' -> '"' 216 '\'' -> '\'' 217 _ -> c