Removed an older version of selectStackFormat
[ghc-hetmet.git] / compiler / parser / LexCore.hs
1 module LexCore where
2
3 import ParserCoreUtils
4 import Char
5 import Numeric
6
7 isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'')
8                || (c == '$') || (c == '-') || (c == '.')
9 isKeywordChar c = isAlpha c || (c == '_') 
10
11 lexer :: (Token -> P a) -> P a 
12 lexer cont []           = cont TKEOF []
13 lexer cont ('\n':cs)    = \line -> lexer cont cs (line+1)
14 lexer cont ('-':'>':cs) = cont TKrarrow cs
15
16 lexer cont (c:cs) 
17       | isSpace c               = lexer cont cs
18       | isLower c || (c == '_') = lexName cont TKname (c:cs)
19       | isUpper c               = lexName cont TKcname (c:cs)
20       | isDigit c || (c == '-') = lexNum cont (c:cs)
21
22 lexer cont ('%':cs)     = lexKeyword cont cs
23 lexer cont ('\'':cs)    = lexChar cont cs
24 lexer cont ('\"':cs)    = lexString [] cont cs 
25 lexer cont ('#':cs)     = cont TKhash cs
26 lexer cont ('(':cs)     = cont TKoparen cs
27 lexer cont (')':cs)     = cont TKcparen cs
28 lexer cont ('{':cs)     = cont TKobrace cs
29 lexer cont ('}':cs)     = cont TKcbrace cs
30 lexer cont ('=':cs)     = cont TKeq cs
31 lexer cont (':':'=':':':cs) = cont TKcoloneqcolon cs
32 lexer cont (':':':':cs) = cont TKcoloncolon cs
33 lexer cont ('*':cs)     = cont TKstar cs
34 lexer cont ('.':cs)     = cont TKdot cs
35 lexer cont ('\\':cs)    = cont TKlambda cs
36 lexer cont ('@':cs)     = cont TKat cs
37 lexer cont ('?':cs)     = cont TKquestion cs
38 lexer cont (';':cs)     = cont TKsemicolon cs
39 -- 20060420 GHC spits out constructors with colon in them nowadays. jds
40 -- 20061103 but it's easier to parse if we split on the colon, and treat them
41 -- as several tokens
42 lexer cont (':':cs)     = cont TKcolon cs
43 -- 20060420 Likewise does it create identifiers starting with dollar. jds
44 lexer cont ('$':cs)     = lexName cont TKname ('$':cs)
45 lexer cont (c:cs)       = failP "invalid character" [c]
46
47
48
49 lexChar cont ('\\':'x':h1:h0:'\'':cs)
50         | isHexEscape [h1,h0] =  cont (TKchar (hexToChar h1 h0)) cs
51 lexChar cont ('\\':cs)   = failP "invalid char character" ('\\':(take 10 cs))
52 lexChar cont ('\'':cs)   = failP "invalid char character" ['\'']
53 lexChar cont ('\"':cs)   = failP "invalid char character" ['\"']
54 lexChar cont (c:'\'':cs) = cont (TKchar c) cs
55
56
57 lexString s cont ('\\':'x':h1:h0:cs) 
58         | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs
59 lexString s cont ('\\':cs) = failP "invalid string character" ['\\']
60 lexString s cont ('\'':cs) = failP "invalid string character" ['\'']
61 lexString s cont ('\"':cs) = cont (TKstring s) cs
62 lexString s cont (c:cs) = lexString (s++[c]) cont cs
63
64 isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c))
65
66 hexToChar h1 h0 = chr (digitToInt h1 * 16 + digitToInt h0)
67
68
69 lexNum cont cs =
70   case cs of
71      ('-':cs) -> f (-1) cs
72      _        -> f 1 cs
73  where f sgn cs = 
74          case span isDigit cs of
75           (digits,'.':c:rest) 
76                 | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest'
77                 where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest))
78                 -- When reading a floating-point number, which is
79                 -- a bit complicated, use the Haskell 98 library function
80           (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest
81
82 lexName cont cstr cs = cont (cstr name) rest
83    where (name,rest) = span isNameChar cs
84
85 lexKeyword cont cs = 
86    case span isKeywordChar cs of
87       ("module",rest) -> cont TKmodule rest
88       ("data",rest)  -> cont TKdata rest
89       ("newtype",rest) -> cont TKnewtype rest
90       ("forall",rest) -> cont TKforall rest     
91       ("rec",rest) -> cont TKrec rest   
92       ("let",rest) -> cont TKlet rest   
93       ("in",rest) -> cont TKin rest     
94       ("case",rest) -> cont TKcase rest 
95       ("of",rest) -> cont TKof rest     
96       ("cast",rest) -> cont TKcast rest 
97       ("note",rest) -> cont TKnote rest 
98       ("external",rest) -> cont TKexternal rest
99       ("local",rest) -> cont TKlocal rest
100       ("_",rest) -> cont TKwild rest
101       _ -> failP "invalid keyword" ('%':cs) 
102