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   ( LexP             -- :: *; = ReadP Lexeme
  19   , Lexeme(..)       -- :: *; Show, Eq
  20
  21   -- lexer
  22   , lex              -- :: LexP
  23   , lexLitChar       -- :: LexP
  24
  25   -- numbers
  26   , Number           -- :: *; Show, Eq
  27
  28   , numberToInt      -- :: Number -> Maybe Int
  29   , numberToInteger  -- :: Number -> Maybe Integer
  30   , numberToRational -- :: Number -> Maybe Integer
  31   , numberToFloat    -- :: Number -> Maybe Float
  32   , numberToDouble   -- :: Number -> Maybe Double
  33
  34   , readIntP         -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
  35   , readOctP         -- :: Num a => ReadP a
  36   , readDecP         -- :: Num a => ReadP a
  37   , readHexP         -- :: Num a => ReadP a
  38   )
  39  where
  40
  41 import Text.ParserCombinators.ReadP
  42
  43 import GHC.Base
  44 import GHC.Num( Num(..), Integer )
  45 import GHC.Show( Show(.. ), showChar, showString,
  46                  isSpace, isAlpha, isAlphaNum,
  47                  isOctDigit, isHexDigit, toUpper )
  48 import GHC.Real( Ratio, Integral, Rational, (%), fromIntegral, fromRational,
  49                  toInteger, (^), (^^) )
  50 import GHC.Float( Float, Double )
  51 import GHC.List
  52 import GHC.Show( ShowS, shows )
  53 import GHC.Enum( minBound, maxBound )
  54 import Data.Maybe
  55 import Data.Either
  56 import Control.Monad
  57
  58 -- -----------------------------------------------------------------------------
  59 -- Lexing types
  60
  61 type LexP = ReadP Lexeme
  62
  63 data Lexeme
  64   = Char   Char
  65   | String String
  66   | Single Char
  67   | Symbol String
  68   | Ident  String
  69   | Number Number
  70  deriving (Eq)
  71
  72 instance Show Lexeme where
  73   showsPrec n (Char c)   = showsPrec n c
  74   showsPrec n (String s) = showsPrec n s
  75   showsPrec _ (Single c) = showChar c
  76   showsPrec _ (Ident s)  = showString s
  77   showsPrec _ (Symbol s) = showString s
  78   showsPrec n (Number x) = showsPrec n x
  79
  80 -- -----------------------------------------------------------------------------
  81 -- Lexing
  82
  83 lex :: LexP
  84 lex =
  85   do skipSpaces
  86      (lexLitChar
  87        +++ lexString
  88          +++ lexSingle
  89            +++ lexSymbol
  90              +++ lexIdf
  91                +++ lexNumber)
  92
  93 -- ----------------------------------------------------------------------
  94 -- symbols
  95
  96 lexSymbol :: LexP
  97 lexSymbol =
  98   do s <- munch1 isSymbolChar
  99      return (Symbol s)
 100  where
 101   isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
 102
 103 -- ----------------------------------------------------------------------
 104 -- identifiers
 105
 106 lexIdf :: LexP
 107 lexIdf =
 108   do c <- satisfy isAlpha
 109      s <- munch isIdfChar
 110      return (Ident (c:s))
 111  where
 112   isIdfChar c = isAlphaNum c || c `elem` "_'"
 113
 114 -- ---------------------------------------------------------------------------
 115 -- Lexing character literals
 116
 117 lexLitChar :: LexP
 118 lexLitChar =
 119   do char '\''
 120      (c,esc) <- lexChar
 121      guard (esc || c /= '\'')
 122      char '\''
 123      return (Char c)
 124
 125 lexChar :: ReadP (Char, Bool)  -- "escaped or not"?
 126 lexChar =
 127   do c <- get
 128      if c == '\\'
 129        then do c <- lexEsc; return (c, True)
 130        else do return (c, False)
 131  where
 132   lexEsc =
 133     lexEscChar
 134       +++ lexNumeric
 135         +++ lexCntrlChar
 136           +++ lexAscii
 137
 138   lexEscChar =
 139     do c <- get
 140        case c of
 141          'a'  -> return '\a'
 142          'b'  -> return '\b'
 143          'f'  -> return '\f'
 144          'n'  -> return '\n'
 145          'r'  -> return '\r'
 146          't'  -> return '\t'
 147          'v'  -> return '\v'
 148          '\\' -> return '\\'
 149          '\"' -> return '\"'
 150          '\'' -> return '\''
 151          _    -> pfail
 152
 153   lexNumeric =
 154     do base <- lexBase
 155        n    <- lexInteger base
 156        guard (n <= toInteger (ord maxBound))
 157        return (chr (fromInteger n))
 158    where
 159     lexBase =
 160       do s <- look
 161          case s of
 162            'o':_ -> do get; return 8
 163            'x':_ -> do get; return 16
 164            _     -> do return 10
 165
 166   lexCntrlChar =
 167     do char '^'
 168        c <- get
 169        case c of
 170          '@'  -> return '\^@'
 171          'A'  -> return '\^A'
 172          'B'  -> return '\^B'
 173          'C'  -> return '\^C'
 174          'D'  -> return '\^D'
 175          'E'  -> return '\^E'
 176          'F'  -> return '\^F'
 177          'G'  -> return '\^G'
 178          'H'  -> return '\^H'
 179          'I'  -> return '\^I'
 180          'J'  -> return '\^J'
 181          'K'  -> return '\^K'
 182          'L'  -> return '\^L'
 183          'M'  -> return '\^M'
 184          'N'  -> return '\^N'
 185          'O'  -> return '\^O'
 186          'P'  -> return '\^P'
 187          'Q'  -> return '\^Q'
 188          'R'  -> return '\^R'
 189          'S'  -> return '\^S'
 190          'T'  -> return '\^T'
 191          'U'  -> return '\^U'
 192          'V'  -> return '\^V'
 193          'W'  -> return '\^W'
 194          'X'  -> return '\^X'
 195          'Y'  -> return '\^Y'
 196          'Z'  -> return '\^Z'
 197          '['  -> return '\^['
 198          '\\' -> return '\^\'
 199          ']'  -> return '\^]'
 200          '^'  -> return '\^^'
 201          '_'  -> return '\^_'
 202          _    -> pfail
 203
 204   lexAscii =
 205     do choice
 206          [ string "NUL" >> return '\NUL'
 207          , string "SOH" >> return '\SOH'
 208          , string "STX" >> return '\STX'
 209          , string "ETX" >> return '\ETX'
 210          , string "EOT" >> return '\EOT'
 211          , string "ENQ" >> return '\ENQ'
 212          , string "ACK" >> return '\ACK'
 213          , string "BEL" >> return '\BEL'
 214          , string "BS"  >> return '\BS'
 215          , string "HT"  >> return '\HT'
 216          , string "LF"  >> return '\LF'
 217          , string "VT"  >> return '\VT'
 218          , string "FF"  >> return '\FF'
 219          , string "CR"  >> return '\CR'
 220          , string "SO"  >> return '\SO'
 221          , string "SI"  >> return '\SI'
 222          , string "DLE" >> return '\DLE'
 223          , string "DC1" >> return '\DC1'
 224          , string "DC2" >> return '\DC2'
 225          , string "DC3" >> return '\DC3'
 226          , string "DC4" >> return '\DC4'
 227          , string "NAK" >> return '\NAK'
 228          , string "SYN" >> return '\SYN'
 229          , string "ETB" >> return '\ETB'
 230          , string "CAN" >> return '\CAN'
 231          , string "EM"  >> return '\EM'
 232          , string "SUB" >> return '\SUB'
 233          , string "ESC" >> return '\ESC'
 234          , string "FS"  >> return '\FS'
 235          , string "GS"  >> return '\GS'
 236          , string "RS"  >> return '\RS'
 237          , string "US"  >> return '\US'
 238          , string "SP"  >> return '\SP'
 239          , string "DEL" >> return '\DEL'
 240          ]
 241
 242
 243 -- ---------------------------------------------------------------------------
 244 -- string literal
 245
 246 lexString :: LexP
 247 lexString =
 248   do char '"'
 249      body id
 250  where
 251   body f =
 252     do (c,esc) <- lexStrItem
 253        if c /= '"' || esc
 254          then body (f.(c:))
 255          else return (String (f ""))
 256
 257   lexStrItem =
 258     (lexEmpty >> lexStrItem)
 259       +++ lexChar
 260
 261   lexEmpty =
 262     do char '\\'
 263        c <- get
 264        case c of
 265          '&'           -> do return ()
 266          _ | isSpace c -> do skipSpaces; char '\\'; return ()
 267          _             -> do pfail
 268
 269 -- ---------------------------------------------------------------------------
 270 -- single character lexemes
 271
 272 lexSingle :: LexP
 273 lexSingle =
 274   do c <- satisfy isSingleChar
 275      return (Single c)
 276  where
 277   isSingleChar c = c `elem` ",;()[]{=}_`"
 278
 279 -- ---------------------------------------------------------------------------
 280 --  Lexing numbers
 281
 282 data Number
 283   = MkNumber
 284     { value    :: Either Integer Rational
 285     , base     :: Base
 286     , digits   :: Digits
 287     , fraction :: Maybe Digits
 288     , exponent :: Maybe Integer
 289     }
 290  deriving (Eq)
 291
 292 type Base   = Int
 293 type Digits = [Int]
 294
 295 instance Show Number where
 296   showsPrec _ x =
 297       showsBase (base x)
 298     . foldr (.) id (map showDigit (digits x))
 299     . showsFrac (fraction x)
 300     . showsExp (exponent x)
 301    where
 302     showsBase 8  = showString "0o"
 303     showsBase 10 = id
 304     showsBase 16 = showString "0x"
 305
 306     showsFrac Nothing   = id
 307     showsFrac (Just ys) =
 308         showChar '.'
 309       . foldr (.) id (map showDigit ys)
 310
 311     showsExp Nothing    = id
 312     showsExp (Just exp) =
 313         showChar 'e'
 314       . shows exp
 315
 316 showDigit :: Int -> ShowS
 317 showDigit n | n <= 9    = shows n
 318             | otherwise = showChar (chr (n + ord 'A' - 10))
 319
 320 lexNumber :: LexP
 321 lexNumber =
 322   do base <- lexBase
 323      lexNumberBase base
 324  where
 325   lexBase =
 326     do s <- look
 327        case s of
 328          '0':'o':_ -> do get; get; return 8
 329          '0':'O':_ -> do get; get; return 8
 330          '0':'x':_ -> do get; get; return 16
 331          '0':'X':_ -> do get; get; return 16
 332          _         -> do return 10
 333
 334 lexNumberBase :: Base -> LexP
 335 lexNumberBase base =
 336   do xs    <- lexDigits base
 337      mFrac <- lexFrac base
 338      mExp  <- lexExp base
 339      return (Number (MkNumber (value xs mFrac mExp) base xs mFrac mExp))
 340  where
 341   value xs mFrac mExp = valueFracExp (val (fromIntegral base) 0 xs) mFrac mExp
 342
 343   valueFracExp a Nothing   mExp
 344     | validIntExp mExp   = Left (valueExpInt a mExp)
 345     | otherwise          = Right (valueExp (fromIntegral a) mExp)
 346   valueFracExp a (Just fs) mExp =
 347     Right (valueExp (fromInteger a + frac (fromIntegral base) 0 1 fs) mExp)
 348
 349    -- only positive exponents allowed
 350   validIntExp Nothing = True
 351   validIntExp (Just e) = e >= 0
 352
 353   valueExpInt a Nothing    = a
 354   valueExpInt a (Just exp) = a * ((fromIntegral base) ^ exp)
 355
 356   valueExp a Nothing    = a
 357   valueExp a (Just exp) = a * ((fromIntegral base) ^^ exp)
 358
 359 lexFrac :: Base -> ReadP (Maybe Digits)
 360 lexFrac base =
 361   do s <- look
 362      case s of
 363        '.' : _ ->
 364          do get
 365             frac <- lexDigits base
 366             return (Just frac)
 367
 368        _ ->
 369          do return Nothing
 370
 371 lexExp :: Base -> ReadP (Maybe Integer)
 372 lexExp base =
 373   do s <- look
 374      case s of
 375        e : _ | e `elem` "eE" && base == 10 ->
 376          do get
 377             (signedExp +++ exp)
 378         where
 379          signedExp =
 380            do c <- char '-' +++ char '+'
 381               n <- lexInteger 10
 382               return (Just (if c == '-' then -n else n))
 383
 384          exp =
 385            do n <- lexInteger 10
 386               return (Just n)
 387
 388        _ ->
 389          do return Nothing
 390
 391 lexDigits :: Int -> ReadP Digits
 392 lexDigits base =
 393   do s  <- look
 394      xs <- scan s id
 395      guard (not (null xs))
 396      return xs
 397  where
 398   scan (c:cs) f = case valDig base c of
 399                     Just n  -> do get; scan cs (f.(n:))
 400                     Nothing -> do return (f [])
 401   scan []     f = do return (f [])
 402
 403 lexInteger :: Base -> ReadP Integer
 404 lexInteger base =
 405   do xs <- lexDigits base
 406      return (val (fromIntegral base) 0 xs)
 407
 408 val :: Num a => a -> a -> Digits -> a
 409 val base y []     = y
 410 val base y (x:xs) = y' `seq` val base y' xs
 411  where
 412   y' = y * base + fromIntegral x
 413
 414 frac :: Integral a => a -> a -> a -> Digits -> Ratio a
 415 frac base a b []     = a % b
 416 frac base a b (x:xs) = a' `seq` b' `seq` frac base a' b' xs
 417  where
 418   a' = a * base + fromIntegral x
 419   b' = b * base
 420
 421 valDig :: Num a => a -> Char -> Maybe Int
 422 valDig 8 c
 423   | '0' <= c && c <= '7' = Just (ord c - ord '0')
 424   | otherwise            = Nothing
 425
 426 valDig 10 c
 427   | '0' <= c && c <= '9' = Just (ord c - ord '0')
 428   | otherwise            = Nothing
 429
 430 valDig 16 c
 431   | '0' <= c && c <= '9' = Just (ord c - ord '0')
 432   | 'a' <= c && c <= 'f' = Just (ord c - ord 'a' + 10)
 433   | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)
 434   | otherwise            = Nothing
 435
 436 -- ----------------------------------------------------------------------
 437 -- conversion
 438
 439 numberToInt :: Number -> Maybe Int
 440 numberToInt x =
 441   case numberToInteger x of
 442     Just n | minBound' <= n && n <= maxBound' -> Just (fromInteger n)
 443     _                                         -> Nothing
 444  where
 445   minBound' = toInteger (minBound :: Int)
 446   maxBound' = toInteger (maxBound :: Int)
 447
 448 numberToInteger :: Number -> Maybe Integer
 449 numberToInteger x =
 450   case value x of
 451     Left n -> Just n
 452     _      -> Nothing
 453
 454 numberToRational :: Number -> Maybe Rational
 455 numberToRational x =
 456   case value x of
 457     Left n  -> Just (fromInteger n)
 458     Right r -> Just r
 459
 460 numberToFloat :: Number -> Maybe Float
 461 numberToFloat x =
 462   case value x of
 463     Left n  -> Just (fromInteger n)
 464     Right r -> Just (fromRational r)
 465
 466 numberToDouble :: Number -> Maybe Double
 467 numberToDouble x =
 468   case value x of
 469     Left n  -> Just (fromInteger n)
 470     Right r -> Just (fromRational r)
 471
 472 -- ----------------------------------------------------------------------
 473 -- other numeric lexing functions
 474
 475 readIntP :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
 476 readIntP base isDigit valDigit =
 477   do s <- munch1 isDigit
 478      return (val base 0 (map valDigit s))
 479
 480 readIntP' :: Num a => a -> ReadP a
 481 readIntP' base = readIntP base isDigit valDigit
 482  where
 483   isDigit  c = maybe False (const True) (valDig base c)
 484   valDigit c = maybe 0     id           (valDig base c)
 485
 486 readOctP, readDecP, readHexP :: Num a => ReadP a
 487 readOctP = readIntP' 8
 488 readDecP = readIntP' 10
 489 readHexP = readIntP' 16