Text/Read/Lex.lhs

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