Use FractionalLit more extensively to improve other pretty printers

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}

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

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 -------------------

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

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
 --------------------------------------------------------------------

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}

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

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}

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