Record the original text along with parsed Rationals: fixes #2245

diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index f077882..a76ee64 100644 (file)
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -72,13 +72,16 @@ module BasicTypes(
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 

-       SuccessFlag(..), succeeded, failed, successIf
+       SuccessFlag(..), succeeded, failed, successIf,
+       
+       FractionalLit(..)

    ) where
 
 import FastString
 import Outputable
 
 import Data.Data hiding (Fixity)
    ) where
 
 import FastString
 import Outputable
 
 import Data.Data hiding (Fixity)

+import Data.Function (on)

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -862,3 +865,25 @@ isEarlyActive (ActiveBefore {}) = True
 isEarlyActive _                        = False
 \end{code}
 
 isEarlyActive _                        = False
 \end{code}
 

+
+
+\begin{code}
+-- Used to represent exactly the floating point literal that we encountered in
+-- the user's source program. This allows us to pretty-print exactly what the user
+-- wrote, which is important e.g. for floating point numbers that can't represented
+-- as Doubles (we used to via Double for pretty-printing). See also #2245.
+data FractionalLit
+  = FL { fl_text :: String         -- How the value was written in the source
+       , fl_value :: Rational      -- Numeric value of the literal
+       }
+  deriving (Data, Typeable)
+
+-- Comparison operations are needed when grouping literals
+-- for compiling pattern-matching (module MatchLit)
+
+instance Eq FractionalLit where
+  (==) = (==) `on` fl_value
+
+instance Ord FractionalLit where
+  compare = compare `on` fl_value
+\end{code}

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index cc00536..2402f98 100644 (file)
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -30,6 +30,7 @@ import Type
 import SrcLoc
 import UniqSet
 import Util
 import SrcLoc
 import UniqSet
 import Util

+import BasicTypes

 import Outputable
 import FastString
 \end{code}
 import Outputable
 import FastString
 \end{code}

@@ -437,7 +438,7 @@ get_lit :: Pat id -> Maybe HsLit
 -- with other HsLits gotten in the same way
 get_lit (LitPat lit)                                     = Just lit
 get_lit (NPat (OverLit { ol_val = HsIntegral i})    mb _) = Just (HsIntPrim   (mb_neg mb i))
 -- with other HsLits gotten in the same way
 get_lit (LitPat lit)                                     = Just lit
 get_lit (NPat (OverLit { ol_val = HsIntegral i})    mb _) = Just (HsIntPrim   (mb_neg mb i))

-get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb f))
+get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb (fl_value f)))

 get_lit (NPat (OverLit { ol_val = HsIsString s })   _  _) = Just (HsStringPrim s)
 get_lit _                                                = Nothing
 
 get_lit (NPat (OverLit { ol_val = HsIsString s })   _  _) = Just (HsStringPrim s)
 get_lit _                                                = Nothing
 

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index e68173a..4211c61 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1595,7 +1595,7 @@ repOverloadedLiteral (OverLit { ol_val = val})
 
 mk_lit :: OverLitVal -> DsM HsLit
 mk_lit (HsIntegral i)   = mk_integer  i
 
 mk_lit :: OverLitVal -> DsM HsLit
 mk_lit (HsIntegral i)   = mk_integer  i

-mk_lit (HsFractional f) = mk_rational f
+mk_lit (HsFractional f) = mk_rational (fl_value f)

 mk_lit (HsIsString s)   = mk_string   s
               
 --------------- Miscellaneous -------------------
 mk_lit (HsIsString s)   = mk_string   s
               
 --------------- Miscellaneous -------------------

diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index be112e0..4842b16 100644 (file)
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -33,6 +33,7 @@ import Literal
 import SrcLoc
 import Data.Ratio
 import Outputable
 import SrcLoc
 import Data.Ratio
 import Outputable

+import BasicTypes

 import Util
 import FastString
 \end{code}
 import Util
 import FastString
 \end{code}

@@ -124,8 +125,8 @@ hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
 litValKey :: OverLitVal -> Bool -> Literal
 litValKey (HsIntegral i)   False = MachInt i
 litValKey (HsIntegral i)   True  = MachInt (-i)
 litValKey :: OverLitVal -> Bool -> Literal
 litValKey (HsIntegral i)   False = MachInt i
 litValKey (HsIntegral i)   True  = MachInt (-i)

-litValKey (HsFractional r) False = MachFloat r
-litValKey (HsFractional r) True  = MachFloat (-r)
+litValKey (HsFractional r) False = MachFloat (fl_value r)
+litValKey (HsFractional r) True  = MachFloat (negate (fl_value r))

 litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr s
 \end{code}
 
 litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr s
 \end{code}
 

@@ -190,8 +191,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
     mb_rat_lit = case (mb_neg, val) of
                   (Nothing, HsIntegral   i) -> Just (fromInteger i)
                   (Just _,  HsIntegral   i) -> Just (fromInteger (-i))
     mb_rat_lit = case (mb_neg, val) of
                   (Nothing, HsIntegral   i) -> Just (fromInteger i)
                   (Just _,  HsIntegral   i) -> Just (fromInteger (-i))

-                  (Nothing, HsFractional f) -> Just f
-                  (Just _, HsFractional f)  -> Just (-f)
+                  (Nothing, HsFractional f) -> Just (fl_value f)
+                  (Just _, HsFractional f)  -> Just (negate (fl_value f))

                   _ -> Nothing
        
     mb_str_lit :: Maybe FastString
                   _ -> Nothing
        
     mb_str_lit :: Maybe FastString

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 5933e9d..3a84239 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -568,7 +568,7 @@ cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 cvtOverLit (IntegerL i)  
   = do { force i; return $ mkHsIntegral i placeHolderType}
 cvtOverLit (RationalL r) 
 cvtOverLit (IntegerL i)  
   = do { force i; return $ mkHsIntegral i placeHolderType}
 cvtOverLit (RationalL r) 

-  = do { force r; return $ mkHsFractional r placeHolderType}
+  = do { force r; return $ mkHsFractional (FL { fl_text = show (fromRational r :: Double), fl_value = r }) placeHolderType}

 cvtOverLit (StringL s)   
   = do { let { s' = mkFastString s }
        ; force s'
 cvtOverLit (StringL s)   
   = do { let { s' = mkFastString s }
        ; force s'

diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs
index 4a565ff..def1e35 100644 (file)
--- a/compiler/hsSyn/HsLit.lhs
+++ b/compiler/hsSyn/HsLit.lhs
@@ -12,7 +12,8 @@ module HsLit where
 #include "HsVersions.h"
 
 import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
 #include "HsVersions.h"
 
 import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )

-import HsTypes (PostTcType)
+import BasicTypes ( FractionalLit(..) )
+import HsTypes  ( PostTcType )

 import Type    ( Type )
 import Outputable
 import FastString
 import Type    ( Type )
 import Outputable
 import FastString

@@ -70,7 +71,7 @@ data HsOverLit id     -- An overloaded literal
 
 data OverLitVal
   = HsIntegral   !Integer      -- Integer-looking literals;
 
 data OverLitVal
   = HsIntegral   !Integer      -- Integer-looking literals;

-  | HsFractional !Rational     -- Frac-looking literals
+  | HsFractional !FractionalLit        -- Frac-looking literals

   | HsIsString   !FastString   -- String-looking literals
   deriving (Data, Typeable)
 
   | HsIsString   !FastString   -- String-looking literals
   deriving (Data, Typeable)
 

@@ -155,6 +156,6 @@ instance OutputableBndr id => Outputable (HsOverLit id) where
 
 instance Outputable OverLitVal where
   ppr (HsIntegral i)   = integer i 
 
 instance Outputable OverLitVal where
   ppr (HsIntegral i)   = integer i 

-  ppr (HsFractional f) = rational f
+  ppr (HsFractional f) = text (fl_text f)

   ppr (HsIsString s)   = pprHsString s
 \end{code}
   ppr (HsIsString s)   = pprHsString s
 \end{code}

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 3d17385..723e0f9 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -187,7 +187,7 @@ mkSimpleHsAlt pat expr
 -- See RnEnv.lookupSyntaxName
 
 mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
 -- See RnEnv.lookupSyntaxName
 
 mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id

-mkHsFractional :: Rational -> PostTcType -> HsOverLit id
+mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id

 mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
 mkHsDo         :: HsStmtContext Name -> [LStmt id] -> HsExpr id
 mkHsComp       :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
 mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
 mkHsDo         :: HsStmtContext Name -> [LStmt id] -> HsExpr id
 mkHsComp       :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 46f7488..2742432 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -68,7 +68,7 @@ import UniqFM
 import DynFlags
 import Module
 import Ctype
 import DynFlags
 import Module
 import Ctype

-import BasicTypes      ( InlineSpec(..), RuleMatchInfo(..) )
+import BasicTypes      ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )

 import Util            ( readRational )
 
 import Control.Monad
 import Util            ( readRational )
 
 import Control.Monad

@@ -541,7 +541,7 @@ data Token
   | ITchar       Char
   | ITstring     FastString
   | ITinteger    Integer
   | ITchar       Char
   | ITstring     FastString
   | ITinteger    Integer

-  | ITrational   Rational
+  | ITrational   FractionalLit

 
   | ITprimchar   Char
   | ITprimstring FastString
 
   | ITprimchar   Char
   | ITprimstring FastString

@@ -1061,7 +1061,7 @@ hexadecimal = (16,hexDigit)
 
 -- readRational can understand negative rationals, exponents, everything.
 tok_float, tok_primfloat, tok_primdouble :: String -> Token
 
 -- readRational can understand negative rationals, exponents, everything.
 tok_float, tok_primfloat, tok_primdouble :: String -> Token

-tok_float        str = ITrational   $! readRational str
+tok_float        str = ITrational   $! FL { fl_text = str, fl_value = readRational str }

 tok_primfloat    str = ITprimfloat  $! readRational str
 tok_primdouble   str = ITprimdouble $! readRational str
 
 tok_primfloat    str = ITprimfloat  $! readRational str
 tok_primdouble   str = ITprimdouble $! readRational str
 

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 5474cfa..8db1aeb 100644 (file)
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -56,6 +56,7 @@ import PrelNames
 import SrcLoc
 import DynFlags
 import Bag
 import SrcLoc
 import DynFlags
 import Bag

+import BasicTypes

 import Maybes
 import Util
 import Outputable
 import Maybes
 import Util
 import Outputable

@@ -276,7 +277,7 @@ mkOverLit (HsIntegral i)
 
 mkOverLit (HsFractional r)
   = do { rat_ty <- tcMetaTy rationalTyConName
 
 mkOverLit (HsFractional r)
   = do { rat_ty <- tcMetaTy rationalTyConName

-       ; return (HsRat r rat_ty) }
+       ; return (HsRat (fl_value r) rat_ty) }

 
 mkOverLit (HsIsString s) = return (HsString s)
 \end{code}
 
 mkOverLit (HsIsString s) = return (HsString s)
 \end{code}

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index cd2cadf..2a17fe8 100644 (file)
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -121,7 +121,7 @@ shortCutLit (HsIntegral i) ty
   | isIntTy ty && inIntRange i   = Just (HsLit (HsInt i))
   | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
   | isIntegerTy ty              = Just (HsLit (HsInteger i ty))
   | isIntTy ty && inIntRange i   = Just (HsLit (HsInt i))
   | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
   | isIntegerTy ty              = Just (HsLit (HsInteger i ty))

-  | otherwise                   = shortCutLit (HsFractional (fromInteger i)) ty
+  | otherwise                   = shortCutLit (HsFractional (FL { fl_text = show i, fl_value = fromInteger i })) ty

        -- The 'otherwise' case is important
        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
        -- so we'll call shortCutIntLit, but of course it's a float
        -- The 'otherwise' case is important
        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
        -- so we'll call shortCutIntLit, but of course it's a float

@@ -129,8 +129,8 @@ shortCutLit (HsIntegral i) ty
        -- literals, compiled without -O
 
 shortCutLit (HsFractional f) ty
        -- literals, compiled without -O
 
 shortCutLit (HsFractional f) ty

-  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
-  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
+  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim (fl_value f)))
+  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim (fl_value f)))

   | otherwise     = Nothing
 
 shortCutLit (HsIsString s) ty
   | otherwise     = Nothing
 
 shortCutLit (HsIsString s) ty