Text/Read/Lex.hs

   1 {-# OPTIONS -fno-implicit-prelude #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  Text.Read.Lex
   5 -- Copyright   :  (c) The University of Glasgow 2002
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  provisional
  10 -- Portability :  non-portable (uses Text.ParserCombinators.ReadP)
  11 --
  12 -- The cut-down Haskell lexer, used by Text.Read
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module Text.Read.Lex
  17   -- lexing types
  18   ( Lexeme(..)  -- :: *; Show, Eq
  19
  20   -- lexer
  21   , lex         -- :: ReadP Lexeme      Skips leading spaces
  22   , hsLex       -- :: ReadP String
  23   , lexChar     -- :: ReadP Char        Reads just one char, with H98 escapes
  24
  25   , readIntP    -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
  26   , readOctP    -- :: Num a => ReadP a
  27   , readDecP    -- :: Num a => ReadP a
  28   , readHexP    -- :: Num a => ReadP a
  29   )
  30  where
  31
  32 import Text.ParserCombinators.ReadP
  33
  34 #ifdef __GLASGOW_HASKELL__
  35 import GHC.Base
  36 import GHC.Num( Num(..), Integer )
  37 import GHC.Show( Show(.. ), isSpace, isAlpha, isAlphaNum )
  38 import GHC.Real( Ratio(..), Integral, Rational, (%), fromIntegral,
  39                  toInteger, (^), (^^), infinity, notANumber )
  40 import GHC.List
  41 import GHC.Enum( maxBound )
  42 #else
  43 import Prelude hiding ( lex )
  44 import Data.Char( chr, ord, isSpace, isAlpha, isAlphaNum )
  45 import Data.Ratio( Ratio, (%) )
  46 #endif
  47 #ifdef __HUGS__
  48 import Hugs.Prelude( Ratio(..) )
  49 #endif
  50 import Data.Maybe
  51 import Control.Monad
  52
  53 -- -----------------------------------------------------------------------------
  54 -- Lexing types
  55
  56 data Lexeme
  57   = Char   Char         -- Quotes removed,
  58   | String String       --      escapes interpreted
  59   | Punc   String       -- Punctuation, eg "(", "::"
  60   | Ident  String       -- Haskell identifiers, e.g. foo, baz
  61   | Symbol String       -- Haskell symbols, e.g. >>, %
  62   | Int Integer
  63   | Rat Rational
  64   | EOF
  65  deriving (Eq, Show)
  66
  67 -- -----------------------------------------------------------------------------
  68 -- Lexing
  69
  70 lex :: ReadP Lexeme
  71 lex = skipSpaces >> lexToken
  72
  73 hsLex :: ReadP String
  74 -- ^ Haskell lexer: returns the lexed string, rather than the lexeme
  75 hsLex = do skipSpaces
  76            (s,_) <- gather lexToken
  77            return s
  78
  79 lexToken :: ReadP Lexeme
  80 lexToken = lexEOF     +++
  81            lexLitChar +++
  82            lexString  +++
  83            lexPunc    +++
  84            lexSymbol  +++
  85            lexId      +++
  86            lexNumber
  87
  88
  89 -- ----------------------------------------------------------------------
  90 -- End of file
  91 lexEOF :: ReadP Lexeme
  92 lexEOF = do s <- look
  93             guard (null s)
  94             return EOF
  95
  96 -- ---------------------------------------------------------------------------
  97 -- Single character lexemes
  98
  99 lexPunc :: ReadP Lexeme
 100 lexPunc =
 101   do c <- satisfy isPuncChar
 102      return (Punc [c])
 103  where
 104   isPuncChar c = c `elem` ",;()[]{}`"
 105
 106 -- ----------------------------------------------------------------------
 107 -- Symbols
 108
 109 lexSymbol :: ReadP Lexeme
 110 lexSymbol =
 111   do s <- munch1 isSymbolChar
 112      if s `elem` reserved_ops then
 113         return (Punc s)         -- Reserved-ops count as punctuation
 114       else
 115         return (Symbol s)
 116  where
 117   isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
 118   reserved_ops   = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]
 119
 120 -- ----------------------------------------------------------------------
 121 -- identifiers
 122
 123 lexId :: ReadP Lexeme
 124 lexId = lex_nan <++ lex_id
 125   where
 126         -- NaN and Infinity look like identifiers, so
 127         -- we parse them first.
 128     lex_nan = (string "NaN"      >> return (Rat notANumber)) +++
 129               (string "Infinity" >> return (Rat infinity))
 130
 131     lex_id = do c <- satisfy isIdsChar
 132                 s <- munch isIdfChar
 133                 return (Ident (c:s))
 134
 135           -- Identifiers can start with a '_'
 136     isIdsChar c = isAlpha c || c == '_'
 137     isIdfChar c = isAlphaNum c || c `elem` "_'"
 138
 139 #ifndef __GLASGOW_HASKELL__
 140 infinity, notANumber :: Rational
 141 infinity   = 1 :% 0
 142 notANumber = 0 :% 0
 143 #endif
 144
 145 -- ---------------------------------------------------------------------------
 146 -- Lexing character literals
 147
 148 lexLitChar :: ReadP Lexeme
 149 lexLitChar =
 150   do char '\''
 151      (c,esc) <- lexCharE
 152      guard (esc || c /= '\'')   -- Eliminate '' possibility
 153      char '\''
 154      return (Char c)
 155
 156 lexChar :: ReadP Char
 157 lexChar = do { (c,_) <- lexCharE; return c }
 158
 159 lexCharE :: ReadP (Char, Bool)  -- "escaped or not"?
 160 lexCharE =
 161   do c <- get
 162      if c == '\\'
 163        then do c <- lexEsc; return (c, True)
 164        else do return (c, False)
 165  where
 166   lexEsc =
 167     lexEscChar
 168       +++ lexNumeric
 169         +++ lexCntrlChar
 170           +++ lexAscii
 171
 172   lexEscChar =
 173     do c <- get
 174        case c of
 175          'a'  -> return '\a'
 176          'b'  -> return '\b'
 177          'f'  -> return '\f'
 178          'n'  -> return '\n'
 179          'r'  -> return '\r'
 180          't'  -> return '\t'
 181          'v'  -> return '\v'
 182          '\\' -> return '\\'
 183          '\"' -> return '\"'
 184          '\'' -> return '\''
 185          _    -> pfail
 186
 187   lexNumeric =
 188     do base <- lexBaseChar
 189        n    <- lexInteger base
 190        guard (n <= toInteger (ord maxBound))
 191        return (chr (fromInteger n))
 192
 193   lexCntrlChar =
 194     do char '^'
 195        c <- get
 196        case c of
 197          '@'  -> return '\^@'
 198          'A'  -> return '\^A'
 199          'B'  -> return '\^B'
 200          'C'  -> return '\^C'
 201          'D'  -> return '\^D'
 202          'E'  -> return '\^E'
 203          'F'  -> return '\^F'
 204          'G'  -> return '\^G'
 205          'H'  -> return '\^H'
 206          'I'  -> return '\^I'
 207          'J'  -> return '\^J'
 208          'K'  -> return '\^K'
 209          'L'  -> return '\^L'
 210          'M'  -> return '\^M'
 211          'N'  -> return '\^N'
 212          'O'  -> return '\^O'
 213          'P'  -> return '\^P'
 214          'Q'  -> return '\^Q'
 215          'R'  -> return '\^R'
 216          'S'  -> return '\^S'
 217          'T'  -> return '\^T'
 218          'U'  -> return '\^U'
 219          'V'  -> return '\^V'
 220          'W'  -> return '\^W'
 221          'X'  -> return '\^X'
 222          'Y'  -> return '\^Y'
 223          'Z'  -> return '\^Z'
 224          '['  -> return '\^['
 225          '\\' -> return '\^\'
 226          ']'  -> return '\^]'
 227          '^'  -> return '\^^'
 228          '_'  -> return '\^_'
 229          _    -> pfail
 230
 231   lexAscii =
 232     do choice
 233          [ (string "SOH" >> return '\SOH') <++
 234            (string "SO"  >> return '\SO')
 235                 -- \SO and \SOH need maximal-munch treatment
 236                 -- See the Haskell report Sect 2.6
 237
 238          , string "NUL" >> return '\NUL'
 239          , string "STX" >> return '\STX'
 240          , string "ETX" >> return '\ETX'
 241          , string "EOT" >> return '\EOT'
 242          , string "ENQ" >> return '\ENQ'
 243          , string "ACK" >> return '\ACK'
 244          , string "BEL" >> return '\BEL'
 245          , string "BS"  >> return '\BS'
 246          , string "HT"  >> return '\HT'
 247          , string "LF"  >> return '\LF'
 248          , string "VT"  >> return '\VT'
 249          , string "FF"  >> return '\FF'
 250          , string "CR"  >> return '\CR'
 251          , string "SI"  >> return '\SI'
 252          , string "DLE" >> return '\DLE'
 253          , string "DC1" >> return '\DC1'
 254          , string "DC2" >> return '\DC2'
 255          , string "DC3" >> return '\DC3'
 256          , string "DC4" >> return '\DC4'
 257          , string "NAK" >> return '\NAK'
 258          , string "SYN" >> return '\SYN'
 259          , string "ETB" >> return '\ETB'
 260          , string "CAN" >> return '\CAN'
 261          , string "EM"  >> return '\EM'
 262          , string "SUB" >> return '\SUB'
 263          , string "ESC" >> return '\ESC'
 264          , string "FS"  >> return '\FS'
 265          , string "GS"  >> return '\GS'
 266          , string "RS"  >> return '\RS'
 267          , string "US"  >> return '\US'
 268          , string "SP"  >> return '\SP'
 269          , string "DEL" >> return '\DEL'
 270          ]
 271
 272
 273 -- ---------------------------------------------------------------------------
 274 -- string literal
 275
 276 lexString :: ReadP Lexeme
 277 lexString =
 278   do char '"'
 279      body id
 280  where
 281   body f =
 282     do (c,esc) <- lexStrItem
 283        if c /= '"' || esc
 284          then body (f.(c:))
 285          else let s = f "" in
 286               return (String s)
 287
 288   lexStrItem = (lexEmpty >> lexStrItem)
 289                +++ lexCharE
 290
 291   lexEmpty =
 292     do char '\\'
 293        c <- get
 294        case c of
 295          '&'           -> do return ()
 296          _ | isSpace c -> do skipSpaces; char '\\'; return ()
 297          _             -> do pfail
 298
 299 -- ---------------------------------------------------------------------------
 300 --  Lexing numbers
 301
 302 type Base   = Int
 303 type Digits = [Int]
 304
 305 lexNumber :: ReadP Lexeme
 306 lexNumber
 307   = lexHexOct  <++      -- First try for hex or octal 0x, 0o etc
 308                         -- If that fails, try for a decimal number
 309     lexDecNumber        -- Start with ordinary digits
 310
 311 lexHexOct :: ReadP Lexeme
 312 lexHexOct
 313   = do  char '0'
 314         base <- lexBaseChar
 315         digits <- lexDigits base
 316         return (Int (val (fromIntegral base) 0 digits))
 317
 318 lexBaseChar :: ReadP Int
 319 -- Lex a single character indicating the base,
 320 -- or return 10 if there isn't one
 321 lexBaseChar = lex_base <++ return 10
 322    where
 323       lex_base = do { c <- get;
 324                       case c of
 325                         'o' -> return 8
 326                         'O' -> return 8
 327                         'x' -> return 16
 328                         'X' -> return 16
 329                         _   -> pfail }
 330
 331 lexDecNumber :: ReadP Lexeme
 332 lexDecNumber =
 333   do xs    <- lexDigits 10
 334      mFrac <- lexFrac <++ return Nothing
 335      mExp  <- lexExp  <++ return Nothing
 336      return (value xs mFrac mExp)
 337  where
 338   value xs mFrac mExp = valueFracExp (val 10 0 xs) mFrac mExp
 339
 340   valueFracExp :: Integer -> Maybe Digits -> Maybe Integer
 341                -> Lexeme
 342   valueFracExp a Nothing Nothing
 343     = Int a                                             -- 43
 344   valueFracExp a Nothing (Just exp)
 345     | exp >= 0  = Int (a * (10 ^ exp))                  -- 43e7
 346     | otherwise = Rat (valExp (fromInteger a) exp)      -- 43e-7
 347   valueFracExp a (Just fs) mExp
 348      = case mExp of
 349          Nothing  -> Rat rat                            -- 4.3
 350          Just exp -> Rat (valExp rat exp)               -- 4.3e-4
 351      where
 352         rat :: Rational
 353         rat = fromInteger a + frac 10 0 1 fs
 354
 355   valExp :: Rational -> Integer -> Rational
 356   valExp rat exp = rat * (10 ^^ exp)
 357
 358 lexFrac :: ReadP (Maybe Digits)
 359 -- Read the fractional part; fail if it doesn't
 360 -- start ".d" where d is a digit
 361 lexFrac = do char '.'
 362              frac <- lexDigits 10
 363              return (Just frac)
 364
 365 lexExp :: ReadP (Maybe Integer)
 366 lexExp = do char 'e' +++ char 'E'
 367             exp <- signedExp +++ lexInteger 10
 368             return (Just exp)
 369  where
 370    signedExp
 371      = do c <- char '-' +++ char '+'
 372           n <- lexInteger 10
 373           return (if c == '-' then -n else n)
 374
 375 lexDigits :: Int -> ReadP Digits
 376 -- Lex a non-empty sequence of digits in specified base
 377 lexDigits base =
 378   do s  <- look
 379      xs <- scan s id
 380      guard (not (null xs))
 381      return xs
 382  where
 383   scan (c:cs) f = case valDig base c of
 384                     Just n  -> do get; scan cs (f.(n:))
 385                     Nothing -> do return (f [])
 386   scan []     f = do return (f [])
 387
 388 lexInteger :: Base -> ReadP Integer
 389 lexInteger base =
 390   do xs <- lexDigits base
 391      return (val (fromIntegral base) 0 xs)
 392
 393 val :: Num a => a -> a -> Digits -> a
 394 -- val base y [d1,..,dn] = y ++ [d1,..,dn], as it were
 395 val base y []     = y
 396 val base y (x:xs) = y' `seq` val base y' xs
 397  where
 398   y' = y * base + fromIntegral x
 399
 400 frac :: Integral a => a -> a -> a -> Digits -> Ratio a
 401 frac base a b []     = a % b
 402 frac base a b (x:xs) = a' `seq` b' `seq` frac base a' b' xs
 403  where
 404   a' = a * base + fromIntegral x
 405   b' = b * base
 406
 407 valDig :: Num a => a -> Char -> Maybe Int
 408 valDig 8 c
 409   | '0' <= c && c <= '7' = Just (ord c - ord '0')
 410   | otherwise            = Nothing
 411
 412 valDig 10 c = valDecDig c
 413
 414 valDig 16 c
 415   | '0' <= c && c <= '9' = Just (ord c - ord '0')
 416   | 'a' <= c && c <= 'f' = Just (ord c - ord 'a' + 10)
 417   | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)
 418   | otherwise            = Nothing
 419
 420 valDecDig c
 421   | '0' <= c && c <= '9' = Just (ord c - ord '0')
 422   | otherwise            = Nothing
 423
 424 -- ----------------------------------------------------------------------
 425 -- other numeric lexing functions
 426
 427 readIntP :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
 428 readIntP base isDigit valDigit =
 429   do s <- munch1 isDigit
 430      return (val base 0 (map valDigit s))
 431
 432 readIntP' :: Num a => a -> ReadP a
 433 readIntP' base = readIntP base isDigit valDigit
 434  where
 435   isDigit  c = maybe False (const True) (valDig base c)
 436   valDigit c = maybe 0     id           (valDig base c)
 437
 438 readOctP, readDecP, readHexP :: Num a => ReadP a
 439 readOctP = readIntP' 8
 440 readDecP = readIntP' 10
 441 readHexP = readIntP' 16