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