7 isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'')
8 isKeywordChar c = isAlpha c || (c == '_')
10 lexer :: (Token -> P a) -> P a
11 lexer cont [] = cont TKEOF []
12 lexer cont ('\n':cs) = \line -> lexer cont cs (line+1)
13 lexer cont ('-':'>':cs) = cont TKrarrow cs
15 | isSpace c = lexer cont cs
16 | isLower c || (c == '_') = lexName cont TKname (c:cs)
17 | isUpper c = lexName cont TKcname (c:cs)
18 | isDigit c || (c == '-') = lexNum cont (c:cs)
19 lexer cont ('%':cs) = lexKeyword cont cs
20 lexer cont ('\'':cs) = lexChar cont cs
21 lexer cont ('\"':cs) = lexString [] cont cs
22 lexer cont ('#':cs) = cont TKhash cs
23 lexer cont ('(':cs) = cont TKoparen cs
24 lexer cont (')':cs) = cont TKcparen cs
25 lexer cont ('{':cs) = cont TKobrace cs
26 lexer cont ('}':cs) = cont TKcbrace cs
27 lexer cont ('=':cs) = cont TKeq cs
28 lexer cont (':':':':cs) = cont TKcoloncolon cs
29 lexer cont ('*':cs) = cont TKstar cs
30 lexer cont ('.':cs) = cont TKdot cs
31 lexer cont ('\\':cs) = cont TKlambda cs
32 lexer cont ('/':'\\':cs) = cont TKbiglambda cs
33 lexer cont ('@':cs) = cont TKat cs
34 lexer cont ('?':cs) = cont TKquestion cs
35 lexer cont (';':cs) = cont TKsemicolon cs
36 lexer cont (c:cs) = failP "invalid character" [c]
38 lexChar cont ('\\':'x':h1:h0:'\'':cs)
39 | isHexEscape [h1,h0] = cont (TKchar (hexToChar h1 h0)) cs
40 lexChar cont ('\\':cs) = failP "invalid char character" ('\\':(take 10 cs))
41 lexChar cont ('\'':cs) = failP "invalid char character" ['\'']
42 lexChar cont ('\"':cs) = failP "invalid char character" ['\"']
43 lexChar cont (c:'\'':cs) = cont (TKchar c) cs
45 lexString s cont ('\\':'x':h1:h0:cs)
46 | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs
47 lexString s cont ('\\':cs) = failP "invalid string character" ['\\']
48 lexString s cont ('\'':cs) = failP "invalid string character" ['\'']
49 lexString s cont ('\"':cs) = cont (TKstring s) cs
50 lexString s cont (c:cs) = lexString (s++[c]) cont cs
52 isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c))
56 (digitToInt h1) * 16 +
65 case span isDigit cs of
66 (digits,'.':c:rest) | isDigit c ->
67 cont (TKrational (numer % denom)) rest'
68 where (fpart,rest') = span isDigit (c:rest)
69 denom = 10^(length fpart)
70 numer = sgn * ((read digits) * denom + (read fpart))
71 (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest
73 lexName cont cstr cs = cont (cstr name) rest
74 where (name,rest) = span isNameChar cs
77 case span isKeywordChar cs of
78 ("module",rest) -> cont TKmodule rest
79 ("data",rest) -> cont TKdata rest
80 ("newtype",rest) -> cont TKnewtype rest
81 ("forall",rest) -> cont TKforall rest
82 ("rec",rest) -> cont TKrec rest
83 ("let",rest) -> cont TKlet rest
84 ("in",rest) -> cont TKin rest
85 ("case",rest) -> cont TKcase rest
86 ("of",rest) -> cont TKof rest
87 ("coerce",rest) -> cont TKcoerce rest
88 ("note",rest) -> cont TKnote rest
89 ("external",rest) -> cont TKexternal rest
90 ("_",rest) -> cont TKwild rest
91 _ -> failP "invalid keyword" ('%':cs)