From: Max Bolingbroke Date: Sun, 15 May 2011 18:36:41 +0000 (+0100) Subject: Use FractionalLit more extensively to improve other pretty printers X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6ddfe9b18d4d280676aab2fa797ddbe6f8a09d6b;ds=sidebyside Use FractionalLit more extensively to improve other pretty printers --- diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index a76ee64..65002d5 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -74,7 +74,7 @@ module BasicTypes( SuccessFlag(..), succeeded, failed, successIf, - FractionalLit(..) + FractionalLit(..), negateFractionalLit, integralFractionalLit ) where import FastString @@ -868,9 +868,9 @@ isEarlyActive _ = False \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 +-- Used (instead of Rational) 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 @@ -878,6 +878,13 @@ data FractionalLit } deriving (Data, Typeable) +negateFractionalLit :: FractionalLit -> FractionalLit +negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value } +negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value } + +integralFractionalLit :: Integer -> FractionalLit +integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i } + -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module MatchLit) @@ -886,4 +893,7 @@ instance Eq FractionalLit where instance Ord FractionalLit where compare = compare `on` fl_value + +instance Outputable FractionalLit where + ppr = text . fl_text \end{code} diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 2402f98..d9aefbe 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -437,14 +437,14 @@ get_lit :: Pat id -> Maybe HsLit -- It doesn't matter which one, because they will only be compared -- 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 (fl_value f))) +get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg negate mb i)) +get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f)) get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim s) get_lit _ = Nothing -mb_neg :: Num a => Maybe b -> a -> a -mb_neg Nothing v = v -mb_neg (Just _) v = -v +mb_neg :: (a -> a) -> Maybe b -> a -> a +mb_neg _ Nothing v = v +mb_neg negate (Just _) v = negate v get_unused_cons :: [Pat Id] -> [DataCon] get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 4211c61..d4e92e1 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1580,7 +1580,7 @@ repLiteral lit mk_integer :: Integer -> DsM HsLit mk_integer i = do integer_ty <- lookupType integerTyConName return $ HsInteger i integer_ty -mk_rational :: Rational -> DsM HsLit +mk_rational :: FractionalLit -> DsM HsLit mk_rational r = do rat_ty <- lookupType rationalTyConName return $ HsRat r rat_ty mk_string :: FastString -> DsM HsLit @@ -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 (fl_value f) +mk_lit (HsFractional f) = mk_rational f mk_lit (HsIsString s) = mk_string s --------------- Miscellaneous ------------------- diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 4842b16..0bd2538 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -65,8 +65,8 @@ dsLit (HsStringPrim s) = return (Lit (MachStr s)) dsLit (HsCharPrim c) = return (Lit (MachChar c)) dsLit (HsIntPrim i) = return (Lit (MachInt i)) dsLit (HsWordPrim w) = return (Lit (MachWord w)) -dsLit (HsFloatPrim f) = return (Lit (MachFloat f)) -dsLit (HsDoublePrim d) = return (Lit (MachDouble d)) +dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) +dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) dsLit (HsChar c) = return (mkCharExpr c) dsLit (HsString str) = mkStringExprFS str @@ -74,8 +74,8 @@ dsLit (HsInteger i _) = mkIntegerExpr i dsLit (HsInt i) = return (mkIntExpr i) dsLit (HsRat r ty) = do - num <- mkIntegerExpr (numerator r) - denom <- mkIntegerExpr (denominator r) + num <- mkIntegerExpr (numerator (fl_value r)) + denom <- mkIntegerExpr (denominator (fl_value r)) return (mkConApp ratio_data_con [Type integer_ty, num, denom]) where (ratio_data_con, integer_ty) @@ -113,8 +113,8 @@ hsLitKey (HsIntPrim i) = mkMachInt i hsLitKey (HsWordPrim w) = mkMachWord w hsLitKey (HsCharPrim c) = MachChar c hsLitKey (HsStringPrim s) = MachStr s -hsLitKey (HsFloatPrim f) = MachFloat f -hsLitKey (HsDoublePrim d) = MachDouble d +hsLitKey (HsFloatPrim f) = MachFloat (fl_value f) +hsLitKey (HsDoublePrim d) = MachDouble (fl_value d) hsLitKey (HsString s) = MachStr s hsLitKey l = pprPanic "hsLitKey" (ppr l) @@ -187,12 +187,12 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ (Just _, HsIntegral i) -> Just (-i) _ -> Nothing - mb_rat_lit :: Maybe Rational + mb_rat_lit :: Maybe FractionalLit mb_rat_lit = case (mb_neg, val) of - (Nothing, HsIntegral i) -> Just (fromInteger i) - (Just _, HsIntegral i) -> Just (fromInteger (-i)) - (Nothing, HsFractional f) -> Just (fl_value f) - (Just _, HsFractional f) -> Just (negate (fl_value f)) + (Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i)) + (Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i))) + (Nothing, HsFractional f) -> Just f + (Just _, HsFractional f) -> Just (negateFractionalLit f) _ -> Nothing mb_str_lit :: Maybe FastString diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 3a84239..492f255 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 (FL { fl_text = show (fromRational r :: Double), fl_value = r }) placeHolderType} + = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType} cvtOverLit (StringL s) = do { let { s' = mkFastString s } ; force s' @@ -602,8 +602,8 @@ allCharLs xs cvtLit :: Lit -> CvtM HsLit cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i } cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w } -cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f } -cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f } +cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) } +cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) } cvtLit (CharL c) = do { force c; return $ HsChar c } cvtLit (StringL s) = do { let { s' = mkFastString s } ; force s' @@ -768,6 +768,9 @@ overloadedLit _ = False void :: Type.Type void = placeHolderType +cvtFractionalLit :: Rational -> FractionalLit +cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r } + -------------------------------------------------------------------- -- Turning Name back into RdrName -------------------------------------------------------------------- diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index def1e35..2cda103 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -41,10 +41,10 @@ data HsLit | HsWordPrim Integer -- Unboxed Word | HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) - | HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION + | HsRat FractionalLit Type -- Genuinely a rational; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) - | HsFloatPrim Rational -- Unboxed Float - | HsDoublePrim Rational -- Unboxed Double + | HsFloatPrim FractionalLit -- Unboxed Float + | HsDoublePrim FractionalLit -- Unboxed Double deriving (Data, Typeable) instance Eq HsLit where @@ -143,9 +143,9 @@ instance Outputable HsLit where ppr (HsStringPrim s) = pprHsString s <> char '#' ppr (HsInt i) = integer i ppr (HsInteger i _) = integer i - ppr (HsRat f _) = rational f - ppr (HsFloatPrim f) = rational f <> char '#' - ppr (HsDoublePrim d) = rational d <> text "##" + ppr (HsRat f _) = ppr f + ppr (HsFloatPrim f) = ppr f <> char '#' + ppr (HsDoublePrim d) = ppr d <> text "##" ppr (HsIntPrim i) = integer i <> char '#' ppr (HsWordPrim w) = integer w <> text "##" @@ -156,6 +156,6 @@ instance OutputableBndr id => Outputable (HsOverLit id) where instance Outputable OverLitVal where ppr (HsIntegral i) = integer i - ppr (HsFractional f) = text (fl_text f) + ppr (HsFractional f) = ppr f ppr (HsIsString s) = pprHsString s \end{code} diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 2742432..b20d2c0 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -547,8 +547,8 @@ data Token | ITprimstring FastString | ITprimint Integer | ITprimword Integer - | ITprimfloat Rational - | ITprimdouble Rational + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit -- Template Haskell extension tokens | ITopenExpQuote -- [| or [e| @@ -1061,9 +1061,12 @@ hexadecimal = (16,hexDigit) -- readRational can understand negative rationals, exponents, everything. tok_float, tok_primfloat, tok_primdouble :: String -> Token -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_float str = ITrational $! readFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str + +readFractionalLit :: String -> FractionalLit +readFractionalLit str = (FL $! str) $! readRational str -- ----------------------------------------------------------------------------- -- Layout processing diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 8db1aeb..5474cfa 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -56,7 +56,6 @@ import PrelNames import SrcLoc import DynFlags import Bag -import BasicTypes import Maybes import Util import Outputable @@ -277,7 +276,7 @@ mkOverLit (HsIntegral i) mkOverLit (HsFractional r) = do { rat_ty <- tcMetaTy rationalTyConName - ; return (HsRat (fl_value r) rat_ty) } + ; return (HsRat r rat_ty) } mkOverLit (HsIsString s) = return (HsString s) \end{code} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 2a17fe8..12b50ac 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 (FL { fl_text = show i, fl_value = fromInteger i })) ty + | otherwise = shortCutLit (HsFractional (integralFractionalLit 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 (fl_value f))) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim (fl_value f))) + | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f)) + | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f)) | otherwise = Nothing shortCutLit (HsIsString s) ty