Skip to content

GitLab

Commit 6ddfe9b1 authored by batterseapower's avatar batterseapower
Browse files

Use FractionalLit more extensively to improve other pretty printers

parent 3391a035
Hide whitespace changes
Inline Side-by-side
compiler/basicTypes/BasicTypes.lhs
View file @ 6ddfe9b1
......@@ -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
View file @ 6ddfe9b1
......@@ -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
View file @ 6ddfe9b1
......@@ -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
View file @ 6ddfe9b1
......@@ -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
View file @ 6ddfe9b1
......@@ -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
View file @ 6ddfe9b1
......@@ -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
View file @ 6ddfe9b1
......@@ -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
View file @ 6ddfe9b1
......@@ -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
View file @ 6ddfe9b1
......@@ -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
......
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