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