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 <[email protected]> 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) _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
