Text/Read/Lex.hs

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