1 % ----------------------------------------------------------------
4 % (c) The University of Glasgow, 1994-2000
8 {-# OPTIONS -fno-implicit-prelude #-}
12 ( LexP -- :: *; = ReadP Lexeme
13 , Lexeme(..) -- :: *; Show, Eq
17 , lexLitChar -- :: LexP
20 , Number -- :: *; Show, Eq
22 , numberToInt -- :: Number -> Maybe Int
23 , numberToInteger -- :: Number -> Maybe Integer
24 , numberToRational -- :: Number -> Maybe Integer
25 , numberToFloat -- :: Number -> Maybe Float
26 , numberToDouble -- :: Number -> Maybe Double
28 , readIntP -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
29 , readOctP -- :: Num a => ReadP a
30 , readDecP -- :: Num a => ReadP a
31 , readHexP -- :: Num a => ReadP a
35 import Text.ParserCombinators.ReadP
38 import GHC.Num( Num(..), Integer )
39 import GHC.Show( Show(.. ), showChar, showString,
40 isSpace, isAlpha, isAlphaNum,
41 isOctDigit, isHexDigit, toUpper )
42 import GHC.Real( Ratio, Integral, Rational, (%), fromIntegral, fromRational,
43 toInteger, (^), (^^) )
44 import GHC.Float( Float, Double )
46 import GHC.Show( ShowS, shows )
47 import GHC.Enum( minBound, maxBound )
53 %*********************************************************
55 \subsection{Lexing types}
57 %*********************************************************
60 type LexP = ReadP Lexeme
71 instance Show Lexeme where
72 showsPrec n (Char c) = showsPrec n c
73 showsPrec n (String s) = showsPrec n s
74 showsPrec _ (Single c) = showChar c
75 showsPrec _ (Ident s) = showString s
76 showsPrec _ (Symbol s) = showString s
77 showsPrec n (Number x) = showsPrec n x
81 %*********************************************************
85 %*********************************************************
100 ------------------------------------------------------------------------
105 do s <- munch1 isSymbolChar
108 isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
110 ------------------------------------------------------------------------
115 do c <- satisfy isAlpha
119 isIdfChar c = isAlphaNum c || c `elem` "_'"
123 %*********************************************************
125 \subsection{Lexing characters and strings}
127 %*********************************************************
130 ------------------------------------------------------------------------
137 guard (esc || c /= '\'')
141 lexChar :: ReadP (Char, Bool) -- "escaped or not"?
145 then do c <- lexEsc; return (c, True)
146 else do return (c, False)
172 guard (n <= toInteger (ord maxBound))
173 return (chr (fromInteger n))
178 'o':_ -> do get; return 8
179 'x':_ -> do get; return 16
222 [ string "NUL" >> return '\NUL'
223 , string "SOH" >> return '\SOH'
224 , string "STX" >> return '\STX'
225 , string "ETX" >> return '\ETX'
226 , string "EOT" >> return '\EOT'
227 , string "ENQ" >> return '\ENQ'
228 , string "ACK" >> return '\ACK'
229 , string "BEL" >> return '\BEL'
230 , string "BS" >> return '\BS'
231 , string "HT" >> return '\HT'
232 , string "LF" >> return '\LF'
233 , string "VT" >> return '\VT'
234 , string "FF" >> return '\FF'
235 , string "CR" >> return '\CR'
236 , string "SO" >> return '\SO'
237 , string "SI" >> return '\SI'
238 , string "DLE" >> return '\DLE'
239 , string "DC1" >> return '\DC1'
240 , string "DC2" >> return '\DC2'
241 , string "DC3" >> return '\DC3'
242 , string "DC4" >> return '\DC4'
243 , string "NAK" >> return '\NAK'
244 , string "SYN" >> return '\SYN'
245 , string "ETB" >> return '\ETB'
246 , string "CAN" >> return '\CAN'
247 , string "EM" >> return '\EM'
248 , string "SUB" >> return '\SUB'
249 , string "ESC" >> return '\ESC'
250 , string "FS" >> return '\FS'
251 , string "GS" >> return '\GS'
252 , string "RS" >> return '\RS'
253 , string "US" >> return '\US'
254 , string "SP" >> return '\SP'
255 , string "DEL" >> return '\DEL'
258 ------------------------------------------------------------------------
267 do (c,esc) <- lexStrItem
270 else return (String (f ""))
273 (lexEmpty >> lexStrItem)
281 _ | isSpace c -> do skipSpaces; char '\\'; return ()
284 ------------------------------------------------------------------------
285 -- single character lexemes
289 do c <- satisfy isSingleChar
292 isSingleChar c = c `elem` ",;()[]{=}_`"
296 %*********************************************************
298 \subsection{Lexing numbers}
300 %*********************************************************
305 { value :: Either Integer Rational
308 , fraction :: Maybe Digits
309 , exponent :: Maybe Integer
316 instance Show Number where
319 . foldr (.) id (map showDigit (digits x))
320 . showsFrac (fraction x)
321 . showsExp (exponent x)
323 showsBase 8 = showString "0o"
325 showsBase 16 = showString "0x"
327 showsFrac Nothing = id
328 showsFrac (Just ys) =
330 . foldr (.) id (map showDigit ys)
332 showsExp Nothing = id
333 showsExp (Just exp) =
337 showDigit :: Int -> ShowS
338 showDigit n | n <= 9 = shows n
339 | otherwise = showChar (chr (n + ord 'A' - 10))
349 '0':'o':_ -> do get; get; return 8
350 '0':'O':_ -> do get; get; return 8
351 '0':'x':_ -> do get; get; return 16
352 '0':'X':_ -> do get; get; return 16
355 lexNumberBase :: Base -> LexP
357 do xs <- lexDigits base
358 mFrac <- lexFrac base
360 return (Number (MkNumber (value xs mFrac mExp) base xs mFrac mExp))
362 value xs mFrac mExp = valueFracExp (val (fromIntegral base) 0 xs) mFrac mExp
364 valueFracExp a Nothing mExp = Left (valueExp a mExp)
365 valueFracExp a (Just fs) mExp =
366 Right (valueExp (fromInteger a + frac (fromIntegral base) 0 1 fs) mExp)
368 valueExp a Nothing = a
369 valueExp a (Just exp) = a * (fromIntegral base ^ exp)
371 lexFrac :: Base -> ReadP (Maybe Digits)
377 frac <- lexDigits base
383 lexExp :: Base -> ReadP (Maybe Integer)
387 e : _ | e `elem` "eE" && base == 10 ->
392 do c <- char '-' +++ char '+'
394 return (Just (if c == '-' then -n else n))
397 do n <- lexInteger 10
403 lexDigits :: Int -> ReadP Digits
407 guard (not (null xs))
410 scan (c:cs) f = case valDig base c of
411 Just n -> do get; scan cs (f.(n:))
412 Nothing -> do return (f [])
413 scan [] f = do return (f [])
415 lexInteger :: Base -> ReadP Integer
417 do xs <- lexDigits base
418 return (val (fromIntegral base) 0 xs)
420 val :: Num a => a -> a -> Digits -> a
422 val base y (x:xs) = y' `seq` val base y' xs
424 y' = y * base + fromIntegral x
426 frac :: Integral a => a -> a -> a -> Digits -> Ratio a
427 frac base a b [] = a % b
428 frac base a b (x:xs) = a' `seq` b' `seq` frac base a' b' xs
430 a' = a * base + fromIntegral x
433 valDig :: Num a => a -> Char -> Maybe Int
435 | '0' <= c && c <= '7' = Just (ord c - ord '0')
436 | otherwise = Nothing
439 | '0' <= c && c <= '9' = Just (ord c - ord '0')
440 | otherwise = Nothing
443 | '0' <= c && c <= '9' = Just (ord c - ord '0')
444 | 'a' <= c && c <= 'f' = Just (ord c - ord 'a' + 10)
445 | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)
446 | otherwise = Nothing
448 ------------------------------------------------------------------------
451 numberToInt :: Number -> Maybe Int
453 case numberToInteger x of
454 Just n | minBound' <= n && n <= maxBound' -> Just (fromInteger n)
457 minBound' = toInteger (minBound :: Int)
458 maxBound' = toInteger (maxBound :: Int)
460 numberToInteger :: Number -> Maybe Integer
466 numberToRational :: Number -> Maybe Rational
469 Left n -> Just (fromInteger n)
472 numberToFloat :: Number -> Maybe Float
475 Left n -> Just (fromInteger n)
476 Right r -> Just (fromRational r)
478 numberToDouble :: Number -> Maybe Double
481 Left n -> Just (fromInteger n)
482 Right r -> Just (fromRational r)
484 ------------------------------------------------------------------------
485 -- other numeric lexing functions
487 readIntP :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
488 readIntP base isDigit valDigit =
489 do s <- munch1 isDigit
490 return (val base 0 (map valDigit s))
492 readIntP' :: Num a => a -> ReadP a
493 readIntP' base = readIntP base isDigit valDigit
495 isDigit c = maybe False (const True) (valDig base c)
496 valDigit c = maybe 0 id (valDig base c)
498 readOctP, readDecP, readHexP :: Num a => ReadP a
499 readOctP = readIntP' 8
500 readDecP = readIntP' 10
501 readHexP = readIntP' 16