@@ -1,14 +1,16 @@
11
22module Lexer (tokenize) where
33
4+import Control.Applicative ((<|>), (<$>), (<*>))
45import Data.Char (isSymbol)
5−import Text.Parsec.Char
6−import Text.Parsec.Combinator
7−import Text.ParserCombinators.Parsec.Prim (parse,(<|>),many,try)
6+import Text.Parsec (Parsec, alphaNum, anyChar, char, choice, digit, eof, letter,
7+ many, many1, manyTill, newline, notFollowedBy, oneOf, parse,
8+ satisfy, string, try, upper)
89import Tokens
910import Control.Monad (liftM)
1011
11−token = NUMBER `liftM` integer
12+token :: Parsec String u Token
13+token = NUMBER <$> integer
1214 <|> whitespace
1315 <|> chrs [ ('(',LPAREN) , (')',RPAREN)
1416 , ('{',LBRACE) , ('}',RBRACE)
@@ -25,34 +27,40 @@ token = NUMBER `liftM` integer
2527 ; return $ STRING s}
2628 <|> do { char '\''; c <- backslashed <|> satisfy (/='\''); char '\''
2729 ; return $ CHAR c}
28− <|> (ID `liftM` variable)
30+ <|> (ID <$> variable)
2931 <|> typeVar
3032 <|> do { try $ string "\r\n" <|> string "\n"; return NEWLINE }
3133
32−str s t = do { try $ string s; return t }
33−chrs = choice . map (uncurry chr)
34−chr c t = do { char c; return t }
35−reserveds = choice . map (uncurry reserved)
36−reserved str token =
37− try $ do {string str; notFollowedBy $ alphaNum <|> char '_'; return token }
34+chrs :: [(Char, Token)] -> Parsec String u Token
35+chrs = choice . map chr
36+ where chr (c, t) = char c >> return t
37+
38+reserveds :: [(String, Token)] -> Parsec String u Token
39+reserveds = choice . map reserved
40+ where reserved (s, t) = try $ string s >>
41+ notFollowedBy (alphaNum <|> char '_') >>
42+ return t
43+
3844anyOp = do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
3945 case op of { ".." -> return DOT2
4046 ; "->" -> return ARROW; "\8594" -> return ARROW
4147 ; _ -> return $ OP op }
4248
43−backslashed = do { char '\\'; c <- satisfy $ const True
49+backslashed :: Parsec String u Char
50+backslashed = do { char '\\'; c <- anyChar
4451 ; return . read $ ['\'','\\',c,'\''] }
4552
46−integer = return . read =<< many1 digit
47−variable = do
48− shd <- letter <|> char '_'
49− stl <- many $ alphaNum <|> char '_' <|> char '\''
50− return $ shd:stl
51−typeVar = do
52− shd <- upper
53− stl <- many $ alphaNum <|> char '_' <|> char '\''
54− return . TYPE $ shd:stl
53+integer :: Parsec String u Int
54+integer = read <$> many1 digit
55+
56+variable :: Parsec String u String
57+variable = identifier $ letter <|> char '_'
58+
59+typeVar :: Parsec String u Token
60+typeVar = TYPE <$> identifier upper
5561
62+identifier :: Parsec String u Char -> Parsec String u String
63+identifier c = (:) <$> c <*> (many $ alphaNum <|> oneOf "_\'")
5664
5765---- White Space and comments ----
5866
@@ -67,8 +75,10 @@ closeComment = manyTill anyChar . choice $
6775 , do { try $ string "{-"; closeComment; closeComment }
6876 ]
6977
78+tokenParser :: Parsec String u [Token]
7079tokenParser = many1 token
7180
81+tokenize :: String -> Either String [Token]
7282tokenize s = case parse tokenParser "" s of
7383 Right ts -> Right ts
7484 Left err -> Left $ "Syntax error: " ++ show err