Commit 3391a035 authored by batterseapower's avatar batterseapower

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

parent ee5addcc
......@@ -72,13 +72,16 @@ module BasicTypes(
inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
SuccessFlag(..), succeeded, failed, successIf
SuccessFlag(..), succeeded, failed, successIf,
FractionalLit(..)
) where
import FastString
import Outputable
import Data.Data hiding (Fixity)
import Data.Function (on)
\end{code}
%************************************************************************
......@@ -862,3 +865,25 @@ isEarlyActive (ActiveBefore {}) = True
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}
......@@ -30,6 +30,7 @@ import Type
import SrcLoc
import UniqSet
import Util
import BasicTypes
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))
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
......
......@@ -1595,7 +1595,7 @@ repOverloadedLiteral (OverLit { ol_val = val})
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 -------------------
......
......@@ -33,6 +33,7 @@ import Literal
import SrcLoc
import Data.Ratio
import Outputable
import BasicTypes
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 (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}
......@@ -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))
(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
......
......@@ -568,7 +568,7 @@ cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
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'
......
......@@ -12,7 +12,8 @@ module HsLit where
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
import HsTypes (PostTcType)
import BasicTypes ( FractionalLit(..) )
import HsTypes ( PostTcType )
import Type ( Type )
import Outputable
import FastString
......@@ -70,7 +71,7 @@ data HsOverLit id -- An overloaded literal
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)
......@@ -155,6 +156,6 @@ instance OutputableBndr id => Outputable (HsOverLit id) where
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}
......@@ -187,7 +187,7 @@ mkSimpleHsAlt pat expr
-- 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
......
......@@ -68,7 +68,7 @@ import UniqFM
import DynFlags
import Module
import Ctype
import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) )
import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
import Util ( readRational )
import Control.Monad
......@@ -541,7 +541,7 @@ data Token
| ITchar Char
| ITstring FastString
| ITinteger Integer
| ITrational Rational
| ITrational FractionalLit
| 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
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
......
......@@ -56,6 +56,7 @@ import PrelNames
import SrcLoc
import DynFlags
import Bag
import BasicTypes
import Maybes
import Util
import Outputable
......@@ -276,7 +277,7 @@ mkOverLit (HsIntegral i)
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}
......
......@@ -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))
| 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
......@@ -129,8 +129,8 @@ shortCutLit (HsIntegral i) 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment