Reorganisation of the source tree
[ghc-hetmet.git] / compiler / parser / LexCore.hs
1 module LexCore where
2
3 import ParserCoreUtils
4 import Ratio
5 import Char
6 import qualified Numeric( readFloat, readDec )
7
8 isNameChar c = isAlpha c || isDigit 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 TKcoloncolon cs
32 lexer cont ('*':cs)     = cont TKstar cs
33 lexer cont ('.':cs)     = cont TKdot cs
34 lexer cont ('\\':cs)    = cont TKlambda cs
35 lexer cont ('@':cs)     = cont TKat cs
36 lexer cont ('?':cs)     = cont TKquestion cs
37 lexer cont (';':cs)     = cont TKsemicolon cs
38 lexer cont (c:cs)       = failP "invalid character" [c]
39
40
41
42 lexChar cont ('\\':'x':h1:h0:'\'':cs)
43         | isHexEscape [h1,h0] =  cont (TKchar (hexToChar h1 h0)) cs
44 lexChar cont ('\\':cs)   = failP "invalid char character" ('\\':(take 10 cs))
45 lexChar cont ('\'':cs)   = failP "invalid char character" ['\'']
46 lexChar cont ('\"':cs)   = failP "invalid char character" ['\"']
47 lexChar cont (c:'\'':cs) = cont (TKchar c) cs
48
49
50 lexString s cont ('\\':'x':h1:h0:cs) 
51         | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs
52 lexString s cont ('\\':cs) = failP "invalid string character" ['\\']
53 lexString s cont ('\'':cs) = failP "invalid string character" ['\'']
54 lexString s cont ('\"':cs) = cont (TKstring s) cs
55 lexString s cont (c:cs) = lexString (s++[c]) cont cs
56
57 isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c))
58
59 hexToChar h1 h0 = chr (digitToInt h1 * 16 + digitToInt h0)
60
61
62 lexNum cont cs =
63   case cs of
64      ('-':cs) -> f (-1) cs
65      _        -> f 1 cs
66  where f sgn cs = 
67          case span isDigit cs of
68           (digits,'.':c:rest) 
69                 | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest'
70                 where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest))
71                 -- When reading a floating-point number, which is
72                 -- a bit complicated, use the Haskell 98 library function
73           (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest
74
75 lexName cont cstr cs = cont (cstr name) rest
76    where (name,rest) = span isNameChar cs
77
78 lexKeyword cont cs = 
79    case span isKeywordChar cs of
80       ("module",rest) -> cont TKmodule rest
81       ("data",rest)  -> cont TKdata rest
82       ("newtype",rest) -> cont TKnewtype rest
83       ("forall",rest) -> cont TKforall rest     
84       ("rec",rest) -> cont TKrec rest   
85       ("let",rest) -> cont TKlet rest   
86       ("in",rest) -> cont TKin rest     
87       ("case",rest) -> cont TKcase rest 
88       ("of",rest) -> cont TKof rest     
89       ("coerce",rest) -> cont TKcoerce rest     
90       ("note",rest) -> cont TKnote rest 
91       ("external",rest) -> cont TKexternal rest
92       ("_",rest) -> cont TKwild rest
93       _ -> failP "invalid keyword" ('%':cs) 
94
95
96 #if __GLASGOW_HASKELL__ >= 504
97 -- The readFloat in the Numeric library will do the job
98
99 readFloat :: (RealFrac a) => ReadS a
100 readFloat = Numeric.readFloat
101
102 #else
103 -- Haskell 98's Numeric.readFloat used to have a bogusly restricted signature
104 -- so it was incapable of reading a rational.  
105 -- So for GHCs that have that old bogus library, here is the code, written out longhand.
106
107 readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
108                                                        (k,t)   <- readExp s] ++
109                  [ (0/0, t) | ("NaN",t)      <- lex r] ++
110                  [ (1/0, t) | ("Infinity",t) <- lex r]
111                where 
112                  readFix r = [(read (ds++ds'), length ds', t)
113                              | (ds,d) <- lexDigits r,
114                                (ds',t) <- lexFrac d ]
115                
116                  lexFrac ('.':ds) = lexDigits ds
117                  lexFrac s        = [("",s)]        
118                  
119                  readExp (e:s) | e `elem` "eE" = readExp' s
120                  readExp s                     = [(0,s)]
121                  
122                  readExp' ('-':s) = [(-k,t) | (k,t) <- Numeric.readDec s]
123                  readExp' ('+':s) = Numeric.readDec s
124                  readExp' s       = Numeric.readDec s
125
126 lexDigits :: ReadS String 
127 lexDigits s =  case span isDigit s of
128                  (cs,s') | not (null cs) -> [(cs,s')]
129                  otherwise               -> []
130 #endif