Refactor number lexing; part of #5688
[packages/base.git] / Text / Read / Lex.hs
index 01ca6ac..fe20a0b 100644 (file)
@@ -1,13 +1,15 @@
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP, NoImplicitPrelude #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Text.Read.Lex
 -- Copyright   :  (c) The University of Glasgow 2002
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
--- 
+--
 -- Maintainer  :  libraries@haskell.org
 -- Stability   :  provisional
--- Portability :  portable
+-- Portability :  non-portable (uses Text.ParserCombinators.ReadP)
 --
 -- The cut-down Haskell lexer, used by Text.Read
 --
 
 module Text.Read.Lex
   -- lexing types
-  ( Lexeme(..)       -- :: *; Show, Eq
-  
+  ( Lexeme(..)  -- :: *; Show, Eq
+
+  , numberToInteger, numberToRational
+
   -- lexer
-  , lex              -- :: ReadP Lexeme        -- Skips leading spaces
-  , hsLex           -- :: ReadP String
-  
-  , readIntP         -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
-  , readOctP         -- :: Num a => ReadP a 
-  , readDecP         -- :: Num a => ReadP a
-  , readHexP         -- :: Num a => ReadP a
+  , lex         -- :: ReadP Lexeme      Skips leading spaces
+  , hsLex       -- :: ReadP String
+  , lexChar     -- :: ReadP Char        Reads just one char, with H98 escapes
+
+  , readIntP    -- :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
+  , readOctP    -- :: Num a => ReadP a
+  , readDecP    -- :: Num a => ReadP a
+  , readHexP    -- :: Num a => ReadP a
   )
  where
 
 import Text.ParserCombinators.ReadP
 
+#ifdef __GLASGOW_HASKELL__
 import GHC.Base
+import GHC.Char
 import GHC.Num( Num(..), Integer )
-import GHC.Show( Show(.. ), showChar, showString,
-                isSpace, isAlpha, isAlphaNum,
-                isOctDigit, isHexDigit, toUpper )
-import GHC.Real( Ratio(..), Integral, Rational, (%), fromIntegral, fromRational, 
-                toInteger, (^), (^^), infinity, notANumber )
-import GHC.Float( Float, Double )
+import GHC.Show( Show(..) )
+import {-# SOURCE #-} GHC.Unicode ( isSpace, isAlpha, isAlphaNum )
+import GHC.Real( Integral, Rational, (%), fromIntegral,
+                 toInteger, (^), infinity, notANumber )
 import GHC.List
-import GHC.Show( ShowS, shows )
-import GHC.Enum( minBound, maxBound )
+import GHC.Enum( maxBound )
+#else
+import Prelude hiding ( lex )
+import Data.Char( chr, ord, isSpace, isAlpha, isAlphaNum )
+import Data.Ratio( Ratio, (%) )
+#endif
+#ifdef __HUGS__
+import Hugs.Prelude( Ratio(..) )
+#endif
 import Data.Maybe
-import Data.Either
 import Control.Monad
 
 -- -----------------------------------------------------------------------------
 -- Lexing types
 
-type LexP = ReadP Lexeme
-
+-- ^ Haskell lexemes.
 data Lexeme
-  = Char   Char                -- Quotes removed, 
-  | String String      --      escapes interpreted
-  | Punc   String      -- Punctuation, eg "(", "::"
-  | Ident  String      -- Haskell identifiers, e.g. foo, baz
-  | Symbol String      -- Haskell symbols, e.g. >>, %
-  | Int Integer
-  | Rat Rational
+  = Char   Char         -- ^ Character literal
+  | String String       -- ^ String literal, with escapes interpreted
+  | Punc   String       -- ^ Punctuation or reserved symbol, e.g. @(@, @::@
+  | Ident  String       -- ^ Haskell identifier, e.g. @foo@, @Baz@
+  | Symbol String       -- ^ Haskell symbol, e.g. @>>@, @:%@
+  | Number Number
   | EOF
  deriving (Eq, Show)
 
+data Number = MkNumber Int              -- Base
+                       Digits           -- Integral part
+            | MkDecimal Digits          -- Integral part
+                        (Maybe Digits)  -- Fractional part
+                        (Maybe Integer) -- Exponent
+            | NotANumber
+            | Infinity
+ deriving (Eq, Show)
+
+numberToInteger :: Number -> Maybe Integer
+numberToInteger (MkNumber base iPart) = Just (val (fromIntegral base) 0 iPart)
+numberToInteger (MkDecimal iPart Nothing mExp)
+    = let i = val 10 0 iPart
+      in case mExp of
+         Nothing             -> Just i
+         Just exp | exp >= 0 -> Just (i * (10 ^ exp))
+         _                   -> Nothing
+numberToInteger _ = Nothing
+
+numberToRational :: Number -> Rational
+numberToRational NotANumber = notANumber
+numberToRational Infinity   = infinity
+numberToRational (MkNumber base iPart) = val (fromIntegral base) 0 iPart % 1
+numberToRational (MkDecimal iPart mFPart mExp)
+ = let i = val 10 0 iPart
+   in case (mFPart, mExp) of
+      (Nothing, Nothing)     -> i % 1
+      (Nothing, Just exp)
+       | exp >= 0            -> (i * (10 ^ exp)) % 1
+       | otherwise           -> i % (10 ^ (- exp))
+      (Just fPart, Nothing)  -> fracExp 0   i fPart
+      (Just fPart, Just exp) -> fracExp exp i fPart
+      -- fracExp is a bit more efficient in calculating the Rational.
+      -- Instead of calculating the fractional part alone, then
+      -- adding the integral part and finally multiplying with
+      -- 10 ^ exp if an exponent was given, do it all at once.
+
 -- -----------------------------------------------------------------------------
 -- Lexing
 
@@ -69,26 +115,26 @@ lex = skipSpaces >> lexToken
 
 hsLex :: ReadP String
 -- ^ Haskell lexer: returns the lexed string, rather than the lexeme
-hsLex = do skipSpaces 
-          (s,_) <- gather lexToken
-          return s
+hsLex = do skipSpaces
+           (s,_) <- gather lexToken
+           return s
 
 lexToken :: ReadP Lexeme
 lexToken = lexEOF     +++
-          lexLitChar +++ 
-          lexString  +++ 
-          lexPunc    +++ 
-          lexSymbol  +++ 
-          lexId      +++ 
-          lexNumber
+           lexLitChar +++
+           lexString  +++
+           lexPunc    +++
+           lexSymbol  +++
+           lexId      +++
+           lexNumber
 
 
 -- ----------------------------------------------------------------------
 -- End of file
 lexEOF :: ReadP Lexeme
 lexEOF = do s <- look
-           guard (null s)
-           return EOF
+            guard (null s)
+            return EOF
 
 -- ---------------------------------------------------------------------------
 -- Single character lexemes
@@ -98,7 +144,7 @@ lexPunc =
   do c <- satisfy isPuncChar
      return (Punc [c])
  where
-  isPuncChar c = c `elem` ",;()[]{}_`"
+  isPuncChar c = c `elem` ",;()[]{}`"
 
 -- ----------------------------------------------------------------------
 -- Symbols
@@ -106,10 +152,10 @@ lexPunc =
 lexSymbol :: ReadP Lexeme
 lexSymbol =
   do s <- munch1 isSymbolChar
-     if s `elem` reserved_ops then 
-       return (Punc s)         -- Reserved-ops count as punctuation
+     if s `elem` reserved_ops then
+        return (Punc s)         -- Reserved-ops count as punctuation
       else
-       return (Symbol s)
+        return (Symbol s)
  where
   isSymbolChar c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
   reserved_ops   = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]
@@ -118,37 +164,54 @@ lexSymbol =
 -- identifiers
 
 lexId :: ReadP Lexeme
-lexId =
-  do c <- satisfy isAlpha
-     s <- munch isIdfChar
-     return (Ident (c:s))
- where
-  isIdfChar c = isAlphaNum c || c `elem` "_'"
+lexId = lex_nan <++ lex_id
+  where
+        -- NaN and Infinity look like identifiers, so
+        -- we parse them first.
+    lex_nan = (string "NaN"      >> return (Number NotANumber)) +++
+              (string "Infinity" >> return (Number Infinity))
+
+    lex_id = do c <- satisfy isIdsChar
+                s <- munch isIdfChar
+                return (Ident (c:s))
+
+          -- Identifiers can start with a '_'
+    isIdsChar c = isAlpha c || c == '_'
+    isIdfChar c = isAlphaNum c || c `elem` "_'"
+
+#ifndef __GLASGOW_HASKELL__
+infinity, notANumber :: Rational
+infinity   = 1 :% 0
+notANumber = 0 :% 0
+#endif
 
 -- ---------------------------------------------------------------------------
 -- Lexing character literals
 
 lexLitChar :: ReadP Lexeme
 lexLitChar =
-  do char '\''
-     (c,esc) <- lexChar
-     guard (esc || c /= '\'')
-     char '\''
+  do _ <- char '\''
+     (c,esc) <- lexCharE
+     guard (esc || c /= '\'')   -- Eliminate '' possibility
+     _ <- char '\''
      return (Char c)
 
-lexChar :: ReadP (Char, Bool)  -- "escaped or not"?
-lexChar =
-  do c <- get
-     if c == '\\'
-       then do c <- lexEsc; return (c, True)
-       else do return (c, False)
- where 
+lexChar :: ReadP Char
+lexChar = do { (c,_) <- lexCharE; return c }
+
+lexCharE :: ReadP (Char, Bool)  -- "escaped or not"?
+lexCharE =
+  do c1 <- get
+     if c1 == '\\'
+       then do c2 <- lexEsc; return (c2, True)
+       else do return (c1, False)
+ where
   lexEsc =
     lexEscChar
       +++ lexNumeric
         +++ lexCntrlChar
           +++ lexAscii
-  
+
   lexEscChar =
     do c <- get
        case c of
@@ -163,22 +226,15 @@ lexChar =
          '\"' -> return '\"'
          '\'' -> return '\''
          _    -> pfail
-  
+
   lexNumeric =
-    do base <- lexBase
+    do base <- lexBaseChar <++ return 10
        n    <- lexInteger base
        guard (n <= toInteger (ord maxBound))
        return (chr (fromInteger n))
-   where
-    lexBase =
-      do s <- look
-         case s of
-           'o':_ -> do get; return 8
-           'x':_ -> do get; return 16
-           _     -> do return 10
-  
+
   lexCntrlChar =
-    do char '^'
+    do _ <- char '^'
        c <- get
        case c of
          '@'  -> return '\^@'
@@ -217,8 +273,12 @@ lexChar =
 
   lexAscii =
     do choice
-         [ string "NUL" >> return '\NUL'
-         , string "SOH" >> return '\SOH'
+         [ (string "SOH" >> return '\SOH') <++
+           (string "SO"  >> return '\SO')
+                -- \SO and \SOH need maximal-munch treatment
+                -- See the Haskell report Sect 2.6
+
+         , string "NUL" >> return '\NUL'
          , string "STX" >> return '\STX'
          , string "ETX" >> return '\ETX'
          , string "EOT" >> return '\EOT'
@@ -231,7 +291,6 @@ lexChar =
          , string "VT"  >> return '\VT'
          , string "FF"  >> return '\FF'
          , string "CR"  >> return '\CR'
-         , string "SO"  >> return '\SO'
          , string "SI"  >> return '\SI'
          , string "DLE" >> return '\DLE'
          , string "DC1" >> return '\DC1'
@@ -259,7 +318,7 @@ lexChar =
 
 lexString :: ReadP Lexeme
 lexString =
-  do char '"'
+  do _ <- char '"'
      body id
  where
   body f =
@@ -267,18 +326,17 @@ lexString =
        if c /= '"' || esc
          then body (f.(c:))
          else let s = f "" in
-             return (String s)
+              return (String s)
+
+  lexStrItem = (lexEmpty >> lexStrItem)
+               +++ lexCharE
 
-  lexStrItem =
-    (lexEmpty >> lexStrItem)
-      +++ lexChar
-  
   lexEmpty =
-    do char '\\'
+    do _ <- char '\\'
        c <- get
        case c of
          '&'           -> do return ()
-         _ | isSpace c -> do skipSpaces; char '\\'; return ()
+         _ | isSpace c -> do skipSpaces; _ <- char '\\'; return ()
          _             -> do pfail
 
 -- ---------------------------------------------------------------------------
@@ -287,88 +345,52 @@ lexString =
 type Base   = Int
 type Digits = [Int]
 
-showDigit :: Int -> ShowS
-showDigit n | n <= 9    = shows n
-            | otherwise = showChar (chr (n + ord 'A' - 10))
-
 lexNumber :: ReadP Lexeme
-lexNumber = do { string "NaN";      return (Rat notANumber) } +++
-           do { string "Infinity"; return (Rat infinity) } +++
-           do { base <- lexBase ;  lexNumberBase base }
- where
-  lexBase =
-    do s <- look
-       case s of
-         '0':'o':_ -> do get; get; return 8
-         '0':'O':_ -> do get; get; return 8
-         '0':'x':_ -> do get; get; return 16
-         '0':'X':_ -> do get; get; return 16
-         _         -> do return 10
-       
-lexNumberBase :: Base -> ReadP Lexeme
-lexNumberBase base =
-  do xs    <- lexDigits base
-     mFrac <- lexFrac base
-     mExp  <- lexExp base
-     return (value xs mFrac mExp)
+lexNumber
+  = lexHexOct  <++      -- First try for hex or octal 0x, 0o etc
+                        -- If that fails, try for a decimal number
+    lexDecNumber        -- Start with ordinary digits
+
+lexHexOct :: ReadP Lexeme
+lexHexOct
+  = do  _ <- char '0'
+        base <- lexBaseChar
+        digits <- lexDigits base
+        return (Number (MkNumber base digits))
+
+lexBaseChar :: ReadP Int
+-- Lex a single character indicating the base; fail if not there
+lexBaseChar = do { c <- get;
+                   case c of
+                        'o' -> return 8
+                        'O' -> return 8
+                        'x' -> return 16
+                        'X' -> return 16
+                        _   -> pfail }
+
+lexDecNumber :: ReadP Lexeme
+lexDecNumber =
+  do xs    <- lexDigits 10
+     mFrac <- lexFrac <++ return Nothing
+     mExp  <- lexExp  <++ return Nothing
+     return (Number (MkDecimal xs mFrac mExp))
+
+lexFrac :: ReadP (Maybe Digits)
+-- Read the fractional part; fail if it doesn't
+-- start ".d" where d is a digit
+lexFrac = do _ <- char '.'
+             fraction <- lexDigits 10
+             return (Just fraction)
+
+lexExp :: ReadP (Maybe Integer)
+lexExp = do _ <- char 'e' +++ char 'E'
+            exp <- signedExp +++ lexInteger 10
+            return (Just exp)
  where
-  baseInteger :: Integer
-  baseInteger = fromIntegral base
-
-  value xs mFrac mExp = valueFracExp (val baseInteger 0 xs) mFrac mExp
-  
-  valueFracExp :: Integer -> Maybe Digits -> Maybe Integer 
-              -> Lexeme
-  valueFracExp a Nothing Nothing       
-    = Int a                                            -- 43
-  valueFracExp a Nothing (Just exp)
-    | exp >= 0  = Int (a * (baseInteger ^ exp))                -- 43e7
-    | otherwise = Rat (valExp (fromInteger a) exp)     -- 43e-7
-  valueFracExp a (Just fs) mExp 
-     = case mExp of
-        Nothing  -> Rat rat                            -- 4.3
-        Just exp -> Rat (valExp rat exp)               -- 4.3e-4
-     where
-       rat :: Rational
-       rat = fromInteger a + frac (fromIntegral base) 0 1 fs
-
-  valExp :: Rational -> Integer -> Rational
-  valExp rat exp = rat * (fromIntegral base ^^ exp)
-
-lexFrac :: Base -> ReadP (Maybe Digits)
-lexFrac base =
-  do s <- look
-     case s of
-       '.' : d : _ | isJust (valDig base d) ->
-       -- The lookahead checks for point and at least one
-       -- valid following digit.  For example 1..n must
-       -- lex the "1" off rather than failing.
-         do get
-            frac <- lexDigits base
-            return (Just frac)
-       
-       _ ->
-         do return Nothing
-
-lexExp :: Base -> ReadP (Maybe Integer)
-lexExp base =
-  do s <- look
-     case s of
-       e : _ | e `elem` "eE" && base == 10 ->
-         do get
-            (signedExp +++ exp)
-        where
-         signedExp =
-           do c <- char '-' +++ char '+'
-              n <- lexInteger 10
-              return (Just (if c == '-' then -n else n))
-         
-         exp =
-           do n <- lexInteger 10
-              return (Just n)
-
-       _ ->
-         do return Nothing
+   signedExp
+     = do c <- char '-' +++ char '+'
+          n <- lexInteger 10
+          return (if c == '-' then -n else n)
 
 lexDigits :: Int -> ReadP Digits
 -- Lex a non-empty sequence of digits in specified base
@@ -379,7 +401,7 @@ lexDigits base =
      return xs
  where
   scan (c:cs) f = case valDig base c of
-                    Just n  -> do get; scan cs (f.(n:))
+                    Just n  -> do _ <- get; scan cs (f.(n:))
                     Nothing -> do return (f [])
   scan []     f = do return (f [])
 
@@ -390,26 +412,34 @@ lexInteger base =
 
 val :: Num a => a -> a -> Digits -> a
 -- val base y [d1,..,dn] = y ++ [d1,..,dn], as it were
-val base y []     = y
+val _    y []     = y
 val base y (x:xs) = y' `seq` val base y' xs
  where
   y' = y * base + fromIntegral x
 
-frac :: Integral a => a -> a -> a -> Digits -> Ratio a
-frac base a b []     = a % b
-frac base a b (x:xs) = a' `seq` b' `seq` frac base a' b' xs
- where
-  a' = a * base + fromIntegral x
-  b' = b * base
-
-valDig :: Num a => a -> Char -> Maybe Int
+-- Calculate a Rational from the exponent [of 10 to multiply with],
+-- the integral part of the mantissa and the digits of the fractional
+-- part. Leaving the calculation of the power of 10 until the end,
+-- when we know the effective exponent, saves multiplications.
+-- More importantly, this way we need at most one gcd instead of three.
+--
+-- frac was never used with anything but Integer and base 10, so
+-- those are hardcoded now (trivial to change if necessary).
+fracExp :: Integer -> Integer -> Digits -> Rational
+fracExp exp mant []
+  | exp < 0     = mant % (10 ^ (-exp))
+  | otherwise   = fromInteger (mant * 10 ^ exp)
+fracExp exp mant (d:ds) = exp' `seq` mant' `seq` fracExp exp' mant' ds
+  where
+    exp'  = exp - 1
+    mant' = mant * 10 + fromIntegral d
+
+valDig :: (Eq a, Num a) => a -> Char -> Maybe Int
 valDig 8 c
   | '0' <= c && c <= '7' = Just (ord c - ord '0')
   | otherwise            = Nothing
 
-valDig 10 c
-  | '0' <= c && c <= '9' = Just (ord c - ord '0')
-  | otherwise            = Nothing
+valDig 10 c = valDecDig c
 
 valDig 16 c
   | '0' <= c && c <= '9' = Just (ord c - ord '0')
@@ -417,6 +447,13 @@ valDig 16 c
   | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)
   | otherwise            = Nothing
 
+valDig _ _ = error "valDig: Bad base"
+
+valDecDig :: Char -> Maybe Int
+valDecDig c
+  | '0' <= c && c <= '9' = Just (ord c - ord '0')
+  | otherwise            = Nothing
+
 -- ----------------------------------------------------------------------
 -- other numeric lexing functions
 
@@ -425,13 +462,14 @@ readIntP base isDigit valDigit =
   do s <- munch1 isDigit
      return (val base 0 (map valDigit s))
 
-readIntP' :: Num a => a -> ReadP a
+readIntP' :: (Eq a, Num a) => a -> ReadP a
 readIntP' base = readIntP base isDigit valDigit
  where
   isDigit  c = maybe False (const True) (valDig base c)
   valDigit c = maybe 0     id           (valDig base c)
 
-readOctP, readDecP, readHexP :: Num a => ReadP a
+readOctP, readDecP, readHexP :: (Eq a, Num a) => ReadP a
 readOctP = readIntP' 8
 readDecP = readIntP' 10
 readHexP = readIntP' 16
+