From: Mart Lubbers Date: Mon, 29 Feb 2016 19:05:01 +0000 (+0100) Subject: updated lexer parser X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=c126dc3a1f66f959407cf3cf33bcba01142591c6;p=cc1516.git updated lexer parser --- diff --git a/src/lex.dcl b/src/lex.dcl index 2c6f0aa..a713e5d 100644 --- a/src/lex.dcl +++ b/src/lex.dcl @@ -2,7 +2,7 @@ definition module lex from Data.Either import :: Either -:: Token :== (Int, TokenValue) +:: Token :== (Int, Int, TokenValue) :: TokenValue //Value tokens = IdentToken [Char] // Identifier diff --git a/src/lex.icl b/src/lex.icl index 32ac048..8aae65a 100644 --- a/src/lex.icl +++ b/src/lex.icl @@ -1,77 +1,93 @@ implementation module lex -import Control.Monad +import Control.Monad, Control.Applicative import Data.Either, Data.Maybe, Data.Map, Data.Func import StdString import StdTuple +from StdFunc import const, o import StdBool import StdList import StdChar -SingleCharTokens :: Map Char TokenValue -SingleCharTokens = fromList [ - ('(', BraceOpenToken), (')', BraceCloseToken), ('{', CBraceOpenToken), - ('}', CBraceCloseToken), ('[', SquareOpenToken), (']', SquareCloseToken), - (',', CommaToken), (':', ColonToken), (';', SColonToken), - ('.', DotToken), ('+', PlusToken), ('*', StarToken), ('/', SlashToken), - ('%', PercentToken), ('=', AssignmentToken), ('<', LesserToken), - ('>', BiggerToken), ('!', ExclamationToken), ('-', DashToken)] - -EscapeMap :: Map Char Char -EscapeMap = fromList [('a', toChar 7), ('b', '\b'), ('f', '\f'), ('n', '\n'), - ('r', '\r'), ('t', '\t'), ('v', '\v')] +import yard lexer :: [Char] -> LexerOutput -lexer x = lexer` x 1 - where - lexer` :: [Char] Int -> LexerOutput - lexer` [] i = Right [] - lexer` x i = case lex x i of - (Right t, rest, i) = lexer` rest i >>= \ts.Right [t:ts] - (Left e, _, _) = Left e +lexer r = case runParser lexProgram r of + (Right p, _) = Right p + (Left e, _) = Left $ toString e + +trans1 :: Char a -> Parser Char a +trans1 t r = item t >>| pure r + +lexProgram :: Parser Char [Token] +lexProgram = lexToken >>= \t->pure [(0, 0, t)] + +lexToken :: Parser Char TokenValue +lexToken = + (lexKw "var" VarToken) <|> + (lexKw "Void" VoidToken) <|> + (lexKw "return" ReturnToken) <|> + (lexKw "if" IfToken) <|> + (lexKw "else" ElseToken) <|> + (lexKw "while" WhileToken) <|> + (lexKw "True" TrueToken) <|> + (lexKw "False" FalseToken) <|> + (lexKw "Int" IntTypeToken) <|> + (lexKw "Bool" BoolTypeToken) <|> + (lexKw "Char" CharTypeToken) <|> + //Escape chars + (liftM CharToken $ item '\'' *> item '\\' *> lexEscape <* item '\'') <|> + //Normal chars + (liftM CharToken $ item '\'' *> satisfy ((<>) '\'') <* item '\'') <|> + (lexOp "::" DoubleColonToken) <|> + (lexOp "!=" NotEqualToken) <|> + (lexOp "<=" LesserEqToken) <|> + (lexOp ">=" GreaterEqToken) <|> + (lexOp "==" EqualsToken) <|> + (lexOp "&&" AmpersandsToken) <|> + (lexOp "||" PipesToken) <|> + (lexOp "[]" EmptyListToken) <|> + (lexOp "->" ArrowToken) <|> + (lexOp "(" BraceOpenToken) <|> + (lexOp ")" BraceCloseToken) <|> + (lexOp "{" CBraceOpenToken) <|> + (lexOp "}" CBraceCloseToken) <|> + (lexOp "[" SquareOpenToken) <|> + (lexOp "]" SquareCloseToken) <|> + (lexOp "," CommaToken) <|> + (lexOp ":" ColonToken) <|> + (lexOp ";" SColonToken) <|> + (lexOp "." DotToken) <|> + (lexOp "+" PlusToken) <|> + (lexOp "*" StarToken) <|> + (lexOp "/" SlashToken) <|> + (lexOp "%" PercentToken) <|> + (lexOp "=" AssignmentToken) <|> + (lexOp "<" LesserToken) <|> + (lexOp ">" BiggerToken) <|> + (lexOp "!" ExclamationToken) <|> + (lexOp "-" DashToken) <|> + //Numbers + (liftM (NumberToken o toInt o toString) $ some $ satisfy isDigit) <|> + //Identifiersr + (liftM IdentToken $ some $ satisfy isIdentChar) <|> + (satisfy isSpace >>| lexToken) + +lexEscape = ( + lexOp "a" (toChar 7) <|> + lexOp "b" '\b' <|> + lexOp "f" '\f' <|> + lexOp "n" '\n' <|> + lexOp "r" '\t' <|> + lexOp "v" '\v' <|> + lexOp "'" '\'' + ) ("Unknown escape", 0) -ret:: TokenValue [Char] Int -> (Either String Token, [Char], Int) -ret tv rest i = (Right (i, tv), rest, i) +lexKw :: String a -> Parser Char a +lexKw kw tv = list (fromString kw) <* check (not o isIdentChar) >>| pure tv -err :: String Int -> (Either String Token, [Char], Int) -err s i = (Left ("Line " +++ toString i +++ ": " +++ s), [], i) +lexOp :: String a -> Parser Char a +lexOp s tv = list (fromString s) >>| pure tv -lex :: [Char] -> (Int -> (Either String Token, [Char], Int)) -lex [] = ret EndOfFileToken [] -lex ['/':'/':xs] = lex (dropWhile ((<>) '\n') xs) -lex ['/':'*':xs] = \i.let (c, r) = span ((<>) ('*','/')) $ zip2 [' ':xs] xs in - lex (tl $ map snd $ tl $ r) (i + length [x\\(x, _)<-c | x == '\n']) -lex ['v':'a':'r':xs] = ret VarToken xs -lex ['V':'o':'i':'d':xs] = ret VoidToken xs -lex ['r':'e':'t':'u':'r':'n':xs] = ret ReturnToken xs -lex ['i':'f':xs] = ret IfToken xs -lex ['e':'l':'s':'e':xs] = ret ElseToken xs -lex ['w':'h':'i':'l':'e':xs] = ret WhileToken xs -lex ['T':'r':'u':'e':xs] = ret TrueToken xs -lex ['F':'a':'l':'s':'e':xs] = ret FalseToken xs -lex ['I':'n':'t':xs] = ret IntTypeToken xs -lex ['C':'h':'a':'r':xs] = ret CharTypeToken xs -lex ['B':'o':'o':'l':xs] = ret BoolTypeToken xs -lex [':':':':xs] = ret DoubleColonToken xs -lex ['!':'=':xs] = ret NotEqualToken xs -lex ['<':'=':xs] = ret LesserEqToken xs -lex ['>':'=':xs] = ret GreaterEqToken xs -lex ['=':'=':xs] = ret EqualsToken xs -lex ['&':'&':xs] = ret AmpersandsToken xs -lex ['|':'|':xs] = ret PipesToken xs -lex ['[':']':xs] = ret EmptyListToken xs -lex ['-':'>':xs] = ret ArrowToken xs -lex ['\'':x:'\'':xs] = ret (CharToken x) xs -lex ['\'':'\\':x:'\'':xs] = case get x EscapeMap of - Just t = ret (CharToken t) xs - _ = err ("Unknown escape: \\" +++ toString x) -lex t=:[x:xs] = case get x SingleCharTokens of - (Just tok) = ret tok xs - Nothing - | x == '\n' = \i.lex xs (i+1) - | isSpace x = lex xs - | isDigit x = let (v, r) = span isDigit t in - ret (NumberToken (toInt $ toString v)) r - | isAlpha x = let (v, r) = span isIdent t in ret (IdentToken v) r - with isIdent c = isAlphanum c || c == '_' - | otherwise = err ("Unexpected character: " +++ toString x) +isIdentChar :: Char -> Bool +isIdentChar c = isAlphanum c || c == '_' diff --git a/src/main.prj b/src/main.prj index 09ebcb5..f7fe0c7 100644 --- a/src/main.prj +++ b/src/main.prj @@ -24,7 +24,7 @@ Global Time: True Stack: True Output - Output: NoConsole + Output: ShowConstructors Font: Courier FontSize: 9 WriteStdErr: False diff --git a/src/parse.icl b/src/parse.icl index af50de6..56bc554 100644 --- a/src/parse.icl +++ b/src/parse.icl @@ -168,7 +168,7 @@ parseTuple p = satTok BraceOpenToken *> <* satTok BraceCloseToken trans2 :: TokenValue (TokenValue -> a) -> Parser Token a -trans2 t f = liftM (f o snd) $ satTok t +trans2 t f = liftM (f o thd3) $ satTok t trans1 :: TokenValue a -> Parser Token a trans1 t r = trans2 t $ const r @@ -176,14 +176,14 @@ trans1 t r = trans2 t $ const r derive gPrint TokenValue derive gEq TokenValue satTok :: TokenValue -> Parser Token Token -satTok t = top >>= \tok=:(pos, tv) -> if (eq t tok) +satTok t = top >>= \tok=:(pos1, pos2, tv) -> if (eq t tok) (return tok) - (fail (printToString tv+++printToString t, pos)) + (fail (printToString tv+++printToString t, pos1)) where - eq (IdentToken _) (_, IdentToken _) = True - eq (NumberToken _) (_, NumberToken _) = True - eq (CharToken _) (_, CharToken _) = True - eq x (_, y) = gEq {|*|} x y + eq (IdentToken _) (_, _, IdentToken _) = True + eq (NumberToken _) (_, _, NumberToken _) = True + eq (CharToken _) (_, _, CharToken _) = True + eq x (_, _, y) = gEq {|*|} x y parseSepList :: TokenValue (Parser Token a) -> Parser Token [a] parseSepList sep p =