[commit: base] master: Avoid making huge Rational's when reading Double/Float; fixes #5688 (4d849e6)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/4d849e6729d25ac4561d597b203c2af8757e6275

>---------------------------------------------------------------

commit 4d849e6729d25ac4561d597b203c2af8757e6275
Author: Ian Lynagh <igloo at earth.li>
Date:   Sun Mar 11 12:31:25 2012 +0000

    Avoid making huge Rational's when reading Double/Float; fixes #5688

>---------------------------------------------------------------

 GHC/Read.lhs     |   13 +++++++++----
 Text/Read/Lex.hs |   36 +++++++++++++++++++++++++++++++++++-
 2 files changed, 44 insertions(+), 5 deletions(-)

diff --git a/GHC/Read.lhs b/GHC/Read.lhs
index 37bcee2..1b3be3d 100644
--- a/GHC/Read.lhs
+++ b/GHC/Read.lhs
@@ -1,6 +1,7 @@
 \begin{code}
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, PatternGuards #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, PatternGuards,
+             ScopedTypeVariables #-}
 {-# OPTIONS_HADDOCK hide #-}
 
 -----------------------------------------------------------------------------
@@ -67,9 +68,10 @@ import Data.Maybe
 import {-# SOURCE #-} GHC.Unicode       ( isDigit )
 import GHC.Num
 import GHC.Real
-import GHC.Float ()
+import GHC.Float
 import GHC.Show
 import GHC.Base
+import GHC.Err
 import GHC.Arr
 -- For defining instances for the generic deriving mechanism
 import GHC.Generics (Arity(..), Associativity(..), Fixity(..))
@@ -472,10 +474,13 @@ convertInt (L.Number n)
  | Just i <- L.numberToInteger n = return (fromInteger i)
 convertInt _ = pfail
 
-convertFrac :: Fractional a => L.Lexeme -> ReadPrec a
+convertFrac :: forall a . RealFloat a => L.Lexeme -> ReadPrec a
 convertFrac (L.Ident "NaN")      = return (0 / 0)
 convertFrac (L.Ident "Infinity") = return (1 / 0)
-convertFrac (L.Number n) = return (fromRational $ L.numberToRational n)
+convertFrac (L.Number n) = let resRange = floatRange (undefined :: a)
+                           in case L.numberToRangedRational resRange n of
+                              Nothing -> return (1 / 0)
+                              Just rat -> return $ fromRational rat
 convertFrac _            = pfail
 
 instance Read Int where
diff --git a/Text/Read/Lex.hs b/Text/Read/Lex.hs
index 7ae8e9f..1a163ee 100644
--- a/Text/Read/Lex.hs
+++ b/Text/Read/Lex.hs
@@ -19,7 +19,7 @@ module Text.Read.Lex
   -- lexing types
   ( Lexeme(..)  -- :: *; Show, Eq
 
-  , numberToInteger, numberToRational
+  , numberToInteger, numberToRational, numberToRangedRational
 
   -- lexer
   , lex         -- :: ReadP Lexeme      Skips leading spaces
@@ -82,6 +82,40 @@ numberToInteger (MkNumber base iPart) = Just (val (fromIntegral base) 0 iPart)
 numberToInteger (MkDecimal iPart Nothing Nothing) = Just (val 10 0 iPart)
 numberToInteger _ = Nothing
 
+-- This takes a floatRange, and if the Rational would be outside of
+-- the floatRange then it may return Nothing. Not that it will not
+-- /necessarily/ return Nothing, but it is good enough to fix the
+-- space problems in #5688
+-- Ways this is conservative:
+-- * the floatRange is in base 2, but we pretend it is in base 10
+-- * we pad the floateRange a bit, just in case it is very small
+--   and we would otherwise hit an edge case
+-- * We only worry about numbers that have an exponent. If they don't
+--   have an exponent then the Rational won't be much larger than the
+--   Number, so there is no problem
+numberToRangedRational :: (Int, Int) -> Number
+                       -> Maybe Rational -- Nothing = Inf
+numberToRangedRational (neg, pos) n@(MkDecimal iPart mFPart (Just exp))
+    = let mFirstDigit = case dropWhile (0 ==) iPart of
+                        iPart'@(_ : _) -> Just (length iPart')
+                        [] -> case mFPart of
+                              Nothing -> Nothing
+                              Just fPart ->
+                                  case span (0 ==) fPart of
+                                  (_, []) -> Nothing
+                                  (zeroes, _) ->
+                                      Just (negate (length zeroes))
+      in case mFirstDigit of
+         Nothing -> Just 0
+         Just firstDigit ->
+             let firstDigit' = firstDigit + fromInteger exp
+             in if firstDigit' > (pos + 3)
+                then Nothing
+                else if firstDigit' < (neg - 3)
+                then Just 0
+                else Just (numberToRational n)
+numberToRangedRational _ n = Just (numberToRational n)
+
 numberToRational :: Number -> Rational
 numberToRational (MkNumber base iPart) = val (fromIntegral base) 0 iPart % 1
 numberToRational (MkDecimal iPart mFPart mExp)