From: Mart Lubbers <mart@martlubbers.net>
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 =