@@ -1,14 +1,16 @@
2module Lexer (tokenize) where
2module Lexer (tokenize) where
4+import Control.Applicative ((<|>), (<$>), (<*>))
4import Data.Char (isSymbol)
5import Data.Char (isSymbol)
5−import Text.Parsec.Char
6+import Text.Parsec (Parsec, alphaNum, anyChar, char, choice, digit, eof, letter,
6−import Text.Parsec.Combinator
7+ many, many1, manyTill, newline, notFollowedBy, oneOf, parse,
7−import Text.ParserCombinators.Parsec.Prim (parse,(<|>),many,try)
8+ satisfy, string, try, upper)
8import Tokens
9import Tokens
9import Control.Monad (liftM)
10import Control.Monad (liftM)
12+token :: Parsec String u Token
11−token = NUMBER `liftM` integer
13+token = NUMBER <$> integer
12 <|> whitespace
14 <|> whitespace
13 <|> chrs [ ('(',LPAREN) , (')',RPAREN)
15 <|> chrs [ ('(',LPAREN) , (')',RPAREN)
14 , ('{',LBRACE) , ('}',RBRACE)
16 , ('{',LBRACE) , ('}',RBRACE)
@@ -25,34 +27,40 @@ token = NUMBER `liftM` integer
25 ; return $ STRING s}
27 ; return $ STRING s}
26 <|> do { char '\''; c <- backslashed <|> satisfy (/='\''); char '\''
28 <|> do { char '\''; c <- backslashed <|> satisfy (/='\''); char '\''
27 ; return $ CHAR c}
29 ; return $ CHAR c}
28− <|> (ID `liftM` variable)
30+ <|> (ID <$> variable)
29 <|> typeVar
31 <|> typeVar
30 <|> do { try $ string "\r\n" <|> string "\n"; return NEWLINE }
32 <|> do { try $ string "\r\n" <|> string "\n"; return NEWLINE }
32−str s t = do { try $ string s; return t }
34+chrs :: [(Char, Token)] -> Parsec String u Token
33−chrs = choice . map (uncurry chr)
35+chrs = choice . map chr
34−chr c t = do { char c; return t }
36+ where chr (c, t) = char c >> return t
38+reserveds :: [(String, Token)] -> Parsec String u Token
35−reserveds = choice . map (uncurry reserved)
39+reserveds = choice . map reserved
36−reserved str token =
40+ where reserved (s, t) = try $ string s >>
37− try $ do {string str; notFollowedBy $ alphaNum <|> char '_'; return token }
41+ notFollowedBy (alphaNum <|> char '_') >>
38anyOp = do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
44anyOp = do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
39 case op of { ".." -> return DOT2
45 case op of { ".." -> return DOT2
40 ; "->" -> return ARROW; "\8594" -> return ARROW
46 ; "->" -> return ARROW; "\8594" -> return ARROW
41 ; _ -> return $ OP op }
47 ; _ -> return $ OP op }
43−backslashed = do { char '\\'; c <- satisfy $ const True
49+backslashed :: Parsec String u Char
50+backslashed = do { char '\\'; c <- anyChar
44 ; return . read $ ['\'','\\',c,'\''] }
51 ; return . read $ ['\'','\\',c,'\''] }
53+integer :: Parsec String u Int
46−integer = return . read =<< many1 digit
54+integer = read <$> many1 digit
56+variable :: Parsec String u String
48− shd <- letter <|> char '_'
57+variable = identifier $ letter <|> char '_'
49− stl <- many $ alphaNum <|> char '_' <|> char '\''
58+
50− return $ shd:stl
59+typeVar :: Parsec String u Token
51−typeVar = do
60+typeVar = TYPE <$> identifier upper
53− stl <- many $ alphaNum <|> char '_' <|> char '\''
54− return . TYPE $ shd:stl
62+identifier :: Parsec String u Char -> Parsec String u String
63+identifier c = (:) <$> c <*> (many $ alphaNum <|> oneOf "_\'")
57---- White Space and comments ----
65---- White Space and comments ----
@@ -67,8 +75,10 @@ closeComment = manyTill anyChar . choice $
67 , do { try $ string "{-"; closeComment; closeComment }
75 , do { try $ string "{-"; closeComment; closeComment }
78+tokenParser :: Parsec String u [Token]
70tokenParser = many1 token
79tokenParser = many1 token
81+tokenize :: String -> Either String [Token]
72tokenize s = case parse tokenParser "" s of
82tokenize s = case parse tokenParser "" s of
73 Right ts -> Right ts
83 Right ts -> Right ts
74 Left err -> Left $ "Syntax error: " ++ show err
84 Left err -> Left $ "Syntax error: " ++ show err