From: Mart Lubbers <mart@martlubbers.net>
Date: Wed, 2 Mar 2016 13:43:35 +0000 (+0100)
Subject: lexer met line numbers
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=7baaa30310aa8c80d9a0e643e03c030f01424d04;p=cc1516.git

lexer met line numbers
---

diff --git a/src/lex.dcl b/src/lex.dcl
index df25ea8..e78d495 100644
--- a/src/lex.dcl
+++ b/src/lex.dcl
@@ -1,8 +1,12 @@
 definition module lex
 
 from Data.Either import :: Either
+from yard import :: Error
 
-:: Token :== (Int, Int, TokenValue)
+:: Token = {
+	line :: Int,
+	column :: Int,
+	token :: TokenValue}
 :: TokenValue
 	//Value tokens
 	= IdentToken String // Identifier
@@ -53,6 +57,6 @@ from Data.Either import :: Either
 	//Special tokens
 	| EndOfFileToken    // EOF
 
-:: LexerOutput :== Either String [Token]
+:: LexerOutput :== Either Error [Token]
 
 lexer :: [Char] -> LexerOutput
diff --git a/src/lex.icl b/src/lex.icl
index a797b1c..9a414cb 100644
--- a/src/lex.icl
+++ b/src/lex.icl
@@ -6,72 +6,115 @@ from StdFunc import o
 import StdBool
 import StdList
 import StdChar
+import StdString
+
+from Text import class Text(textSize,concat), instance Text String
 
 import yard
 
 lexer :: [Char] -> LexerOutput
-lexer r = case runParser lexProgram r of
+lexer r = case runParser (lexProgram 1 1) r of
 	(Right p, _) = Right p
-	(Left e, _) = Left $ toString e
+	(Left e, _) = Left e
+
+lexProgram :: Int Int -> Parser Char [Token]
+lexProgram line column = lexToken >>= \t->case t of
+		LexEOF = pure []
+		(LexItemError e) = fail <?> 
+			PositionalError line column ("LexerError: " +++ e)
+		(LexToken c t) = lexProgram line (column+c)
+			>>= \rest->pure [{line=line, column=column, token=t}:rest]
+		LexNL = lexProgram (line+1) 1
+		(LexSpace l c) = lexProgram (line+l) (column+c)
 
-lexProgram :: Parser Char [Token]
-lexProgram = catMaybes <$> some lexToken <* eof
-	>>= \ts->pure $ (map (\t->(0, 0, t)) ts)
+:: LexItem 
+	= LexToken Int TokenValue
+	| LexSpace Int Int
+	| LexNL 
+	| LexEOF 
+	| LexItemError String
 
-//Of hier een record van maken
-//lexToken :: Parser Char (Maybe (Int, Int, Int, TokenValue))
-lexToken :: Parser Char (Maybe TokenValue)
+lexToken :: Parser Char LexItem
 lexToken = 
-    //Comments
-    (list (fromString "//") >>| lexUntilNL >>| pure Nothing) <|>
-    (list (fromString "/*") >>| lexUntilCommentClose >>| pure Nothing) <|>
+	//Comments
+	lexBlockComment <|> lexComment <|>
 	//Keyword tokens
-	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 "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 tokens
-	liftM (Just o CharToken)
-		(list (fromString "'\\") *> lexEscape <* item '\'') <|>
-	//Normal chars tokens
-	liftM (Just o CharToken)
-		(item '\'' *> satisfy ((<>) '\'') <* item '\'') <|>
+	//Character tokens
+	lexEscape <|> lexCharacter <|>
 	//Two char ops tokens
-	lexOp "::" DoubleColonToken <|> lexOp "!=" NotEqualToken <|>
-	lexOp "<=" LesserEqToken <|> lexOp ">=" GreaterEqToken <|>
-	lexOp "==" EqualsToken <|> lexOp "&&" AmpersandsToken <|>
-	lexOp "||" PipesToken <|> lexOp "[]" EmptyListToken <|>
-	lexOp "->" ArrowToken <|> 
+	lexWord "::" DoubleColonToken <|> lexWord "!=" NotEqualToken <|>
+	lexWord "<=" LesserEqToken <|> lexWord ">=" GreaterEqToken <|>
+	lexWord "==" EqualsToken <|> lexWord "&&" AmpersandsToken <|>
+	lexWord "||" PipesToken <|> lexWord "[]" EmptyListToken <|>
+	lexWord "->" ArrowToken <|> 
 	//One char ops tokens
-    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 <|>
-	//Number tokens
-	liftM (Just o NumberToken o toInt o toString) (some $ satisfy isDigit) <|>
-	//Ident tokens
-	liftM (Just o IdentToken o toString) (some $ satisfy isIdentChar) <|>
-	(satisfy isSpace >>| pure Nothing)
+    lexWord "(" BraceOpenToken <|>
+	lexWord ")" BraceCloseToken <|> lexWord "{" CBraceOpenToken <|>
+	lexWord "}" CBraceCloseToken <|> lexWord "[" SquareOpenToken <|>
+	lexWord "]" SquareCloseToken <|> lexWord "," CommaToken <|>
+	lexWord ":" ColonToken <|> lexWord ";" SColonToken <|>
+	lexWord "." DotToken <|> lexWord "+" PlusToken <|>
+	lexWord "*" StarToken <|> lexWord "/" SlashToken <|>
+	lexWord "%" PercentToken <|> lexWord "=" AssignmentToken <|>
+	lexWord "<" LesserToken <|> lexWord ">" BiggerToken <|>
+	lexWord "!" ExclamationToken <|> lexWord "-" DashToken <|>
+	//Number and identifier tokens
+	lexNumber <|> lexIdentifier <|>
+	(item '\n' >>| pure LexNL) <|>
+	(satisfy isSpace >>| (pure $ LexSpace 0 1)) <|>
+	(eof >>| pure LexEOF)
 	where
+		lexWord :: String TokenValue -> Parser Char LexItem
+		lexWord s tv = list (fromString s) >>| pure (LexToken (textSize s) tv)
+
+		lexKw :: String TokenValue -> Parser Char LexItem
+		lexKw kw tv = lexWord kw tv <* check (not o isIdentChar)
+
 		lexUntilNL = top until (eof <|> (item '\n' >>| pure Void))
-		lexUntilCommentClose = top until (list (fromString "*/"))
+
+		lexComment :: Parser Char LexItem
+    	lexComment = list (fromString "//") >>| lexUntilNL 
+			>>= \chars->pure LexNL
+
+		lexBlockComment :: Parser Char LexItem
+		lexBlockComment = list (fromString "/*") 
+			>>| (top until (list (fromString "*/")))
+			>>= \chars->pure $ widthHeight chars 0 0
+			where
+				widthHeight :: [Char] Int Int -> LexItem
+				widthHeight [] l c = LexSpace l c
+				widthHeight ['\n':xs] l _ = widthHeight xs (l+1) 0
+				widthHeight [x:xs] l c = widthHeight xs l (c+1)
+
+		lexNumber :: Parser Char LexItem
+		lexNumber = toString <$> some (satisfy isDigit) 
+			>>= \si->pure $ LexToken (textSize si) (NumberToken $ toInt si)
+
+		lexIdentifier :: Parser Char LexItem
+		lexIdentifier = toString <$> some (satisfy isIdentChar)
+			>>= \si->pure $ LexToken (textSize si) (IdentToken si)
+
 		isIdentChar c = isAlphanum c || c == '_'
-		lexOp s tv = list (fromString s) >>| pure (Just tv)
-		lexKw kw tv = lexOp kw tv <* check (not o isIdentChar)
-		lexEscape = fromJust <$> ((
-			lexOp "a" (toChar 7) <|> lexOp "b" '\b' <|> lexOp "f" '\f' <|>
-			lexOp "n" '\n' <|> lexOp "r" '\t' <|> lexOp "v" '\v' <|>
-			lexOp "'" '\'') <?> LexError "Unknown escape")
+
+		lexCharacter :: Parser Char LexItem
+		lexCharacter = item '\'' *> satisfy ((<>) '\'') <* item '\''
+			>>= \char->pure $ LexToken 3 (CharToken char)
+
+		lexEscape :: Parser Char LexItem
+		lexEscape = item '\'' *> item '\\' *> top <* item '\''
+			>>= \char->pure case char of
+				'a' = LexToken 4 (CharToken $ toChar 7)
+				'b' = LexToken 4 (CharToken '\b')
+				'b' = LexToken 4 (CharToken '\b')
+				'f' = LexToken 4 (CharToken '\f')
+				'n' = LexToken 4 (CharToken '\n')
+				'r' = LexToken 4 (CharToken '\t')
+				'v' = LexToken 4 (CharToken '\v')
+				'\'' =LexToken 4 (CharToken '\'')
+				c = (LexItemError $ "Unknown escape: " +++ toString c)
diff --git a/src/main.icl b/src/main.icl
index 0dfab03..ee1e0bd 100644
--- a/src/main.icl
+++ b/src/main.icl
@@ -16,6 +16,7 @@ from Text import class Text(concat), instance Text String
 
 import parse
 import lex
+from yard import :: Error, instance toString Error
 
 :: Opts = {
 	program :: String,
@@ -44,14 +45,21 @@ Start w
 	(Right cs)
 	# lexOut = lexer cs
 	# stdin = if (not args.lex) stdin (case lexOut of
-		(Left lex) = stdin <<< toString lex
-		(Right toks) = stdin <<< 
-			concat (map (\(_, _, t)->printToString t +++ "\n") toks))
+		(Right toks) = 
+			stdin <<< "---LEXER\n" <<< printTokens toks <<< "---LEXER\n"
+		_ = stdin)
 	# parseOut = parser lexOut
 	# stdin = if (not args.parse) stdin (case parser lexOut of
-		(Left parse) = stdin <<< toString parse
-		(Right ast) = stdin <<< toString ast)
+		(Right ast) = 
+			stdin <<<  "---PARSER\n" <<< toString ast <<< "---PARSER\n" 
+		(Left parse) = stdin <<< toString parse)
 	= snd $ fclose stdin w
+		where
+			printTokens :: [Token] -> String
+			printTokens ts = concat $ flatten $ map pt ts
+				where
+					pt {line,column,token} = [toString line, ":", 
+						toString column, ": ", printToString token, "\n"]
 
 parseArgs :: *World -> (Opts, *World)
 parseArgs w
diff --git a/src/parse.dcl b/src/parse.dcl
index 55d8a95..aca0ba4 100644
--- a/src/parse.dcl
+++ b/src/parse.dcl
@@ -5,7 +5,7 @@ from Data.Maybe import :: Maybe
 
 import lex
 
-:: ParserOutput :== Either String AST
+:: ParserOutput :== Either Error AST
 
 :: AST = AST [VarDecl] [FunDecl]
 :: VarDecl = VarDecl Type String Expr
diff --git a/src/parse.icl b/src/parse.icl
index 7320b11..acd7d9c 100644
--- a/src/parse.icl
+++ b/src/parse.icl
@@ -18,11 +18,8 @@ import yard
 import lex
 
 parser :: LexerOutput -> ParserOutput
-parser (Left e) = Left $ toString $ LexError e
-parser (Right r) = case runParser parseProgram r of
-	(Right p, []) = Right p
-	(Right p, x) = Left "Unparsed tokens: "//TODO
-	(Left e, _) = Left $ toString e
+parser (Left e) = Left e
+parser (Right r) = fst $ runParser parseProgram r
 
 parseProgram :: Parser Token AST
 parseProgram = liftM2 AST (many parseVarDecl) (some parseFunDecl) 
@@ -168,7 +165,7 @@ parseTuple p = satTok BraceOpenToken *>
 	<* satTok BraceCloseToken
 
 trans2 :: TokenValue (TokenValue -> a) -> Parser Token a
-trans2 t f = liftM (f o thd3) $ satTok t
+trans2 t f = liftM (\{token}->f token) $ satTok t
 
 trans1 :: TokenValue a -> Parser Token a
 trans1 t r = trans2 t $ const r
@@ -176,14 +173,13 @@ trans1 t r = trans2 t $ const r
 derive gPrint TokenValue
 derive gEq TokenValue
 satTok :: TokenValue -> Parser Token Token
-satTok t = top >>= \tok=:(pos1, pos2, tv) -> if (eq t tok) 
-                                            (return tok) 
-                                            (fail <?> Unexpected (printToString tv) (pos1, pos2))
+satTok t = top >>= \tok=:{line,column,token} -> if (eq t token) 
+	(return tok) (fail <?> PositionalError line column ("ParseError: Unexpected token: " +++ printToString token))
 	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 = 
diff --git a/src/yard.dcl b/src/yard.dcl
index a40b42d..7d08a9c 100644
--- a/src/yard.dcl
+++ b/src/yard.dcl
@@ -8,7 +8,7 @@ from Control.Monad import class Monad
 from Control.Applicative import class Applicative, class Alternative
 import Data.Void
 
-:: Error = ParseError | LexError String | Unexpected String (Int, Int)
+:: Error = PositionalError Int Int String | Error String
 :: Parser a b = Parser ([a] -> (Either Error b, [a]))
 
 instance Functor (Parser a)
diff --git a/src/yard.icl b/src/yard.icl
index 7b74454..9b2ec23 100644
--- a/src/yard.icl
+++ b/src/yard.icl
@@ -15,18 +15,15 @@ from Data.Func import $
 import Data.Void
 
 instance toString Error where
-	toString ParseError = "General parse error"
-	toString (LexError e) = "Lexer error: " +++ e
-    toString (Unexpected e (l,c)) = "Unexpected " +++ e +++ " at " 
-                                        +++ (toString l) +++ ":" +++ (toString c)
+	toString (PositionalError l c e) =
+		concat [toString l,":",toString c,": ",e, "\n"]
+	toString (Error e) = concat ["-:-: ", e, "\n"]
 
 runParser :: (Parser a b) [a] -> (Either Error b, [a])
 runParser (Parser f) i = f i
 
 instance + Error where
-    (+) ParseError r = r 
-    (+) r ParseError = r
-    (+) r _          = r
+	(+) r1 r2 = r2 //TODO
  
 instance Functor (Parser a) where
     fmap f m = liftM f m
@@ -41,7 +38,7 @@ instance Monad (Parser a) where
         (Left e, _)     = (Left e, i)
 
 instance Alternative (Parser a) where
-    empty       = Parser \i -> (Left ParseError, i)
+    empty       = Parser \i -> (Left $ Error "" , i)
     (<|>) p1 p2 = Parser \i -> case runParser p1 i of
         (Right r, rest) = (Right r, rest)
         (Left e1, rest) = case runParser p2 i of
@@ -59,12 +56,12 @@ fail = empty
 
 top :: Parser a a
 top = Parser \i -> case i of
-    []      = (Left ParseError, [])
+    []      = (Left $ Error "", [])
     [x:xs]  = (Right x, xs)
 
 peek :: Parser a a
 peek = Parser \i -> case i of
-    []      = (Left ParseError, [])
+    []      = (Left $ Error "", [])
     [x:xs]  = (Right x, [x:xs])
 
 //runs the left parser until the right parser succeeds. Returns the result of the left parser 
@@ -88,7 +85,7 @@ peek = Parser \i -> case i of
 eof :: Parser a Void
 eof = Parser \i -> case i of 
     []      = (Right Void, [])
-    _       = (Left ParseError, i)
+    _       = (Left $ Error "", i)
 
 satisfy :: (a -> Bool) -> Parser a a
 satisfy f = top >>= \r -> if (f r) (return r) fail