From: Max Bolingbroke Date: Sun, 15 May 2011 17:50:54 +0000 (+0100) Subject: Record the original text along with parsed Rationals: fixes #2245 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=3391a03562d4056de7b16cd0f632e6c43ae44cca 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 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -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} diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index cc00536..2402f98 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -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 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index e68173a..4211c61 100644 --- 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 (HsFractional f) = mk_rational f +mk_lit (HsFractional f) = mk_rational (fl_value f) mk_lit (HsIsString s) = mk_string s --------------- Miscellaneous ------------------- diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index be112e0..4842b16 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -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 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 5933e9d..3a84239 100644 --- 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) - = 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' diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index 4a565ff..def1e35 100644 --- 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 ) -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} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 3d17385..723e0f9 100644 --- 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 -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 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 46f7488..2742432 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -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 diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 5474cfa..8db1aeb 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -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} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index cd2cadf..2a17fe8 100644 --- 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)) - | 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