X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsLit.lhs;h=2cda10347982ebb11f741740f41f846dde156ff8;hp=55260ebff471cc58e46c33d6acd0680d00e443c9;hb=6ddfe9b18d4d280676aab2fa797ddbe6f8a09d6b;hpb=6821c8a47c0fc61a2d989d368f926cc0ded776e9 diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index 55260eb..2cda103 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -5,16 +5,20 @@ \section[HsLit]{Abstract syntax: source-language literals} \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} + 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 -import Ratio ( Rational ) + +import Data.Data \end{code} @@ -37,10 +41,11 @@ 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 (HsChar x1) == (HsChar x2) = x1==x2 @@ -57,48 +62,76 @@ instance Eq HsLit where _ == _ = False data HsOverLit id -- An overloaded literal - = HsIntegral !Integer (SyntaxExpr id) PostTcType -- Integer-looking literals; - | HsFractional !Rational (SyntaxExpr id) PostTcType -- Frac-looking literals - | HsIsString !FastString (SyntaxExpr id) PostTcType -- String-looking literals - -- Before type checking, the SyntaxExpr is 'fromInteger' or 'fromRational' - -- After type checking, it is (fromInteger 3) or lit_78; that is, - -- the expression that should replace the literal. - -- This is unusual, because we're replacing 'fromInteger' with a call - -- to fromInteger. Reason: it allows commoning up of the fromInteger - -- calls, which wouldn't be possible if the desguarar made the application - -- - -- The PostTcType in each branch records the type the overload literal is - -- found to have. - -overLitExpr :: HsOverLit id -> SyntaxExpr id -overLitExpr (HsIntegral _ e _) = e -overLitExpr (HsFractional _ e _) = e -overLitExpr (HsIsString _ e _) = e - -overLitType :: HsOverLit id -> PostTcType -overLitType (HsIntegral _ _ t) = t -overLitType (HsFractional _ _ t) = t -overLitType (HsIsString _ _ t) = t + = OverLit { + ol_val :: OverLitVal, + ol_rebindable :: Bool, -- Note [ol_rebindable] + ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses] + ol_type :: PostTcType } + deriving (Data, Typeable) + +data OverLitVal + = HsIntegral !Integer -- Integer-looking literals; + | HsFractional !FractionalLit -- Frac-looking literals + | HsIsString !FastString -- String-looking literals + deriving (Data, Typeable) + +overLitType :: HsOverLit a -> Type +overLitType = ol_type +\end{code} + +Note [ol_rebindable] +~~~~~~~~~~~~~~~~~~~~ +The ol_rebindable field is True if this literal is actually +using rebindable syntax. Specifically: + + False iff ol_witness is the standard one + True iff ol_witness is non-standard + +Equivalently it's True if + a) RebindableSyntax is on + b) the witness for fromInteger/fromRational/fromString + that happens to be in scope isn't the standard one +Note [Overloaded literal witnesses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Before* type checking, the SyntaxExpr in an HsOverLit is the +name of the coercion function, 'fromInteger' or 'fromRational'. +*After* type checking, it is a witness for the literal, such as + (fromInteger 3) or lit_78 +This witness should replace the literal. +This dual role is unusual, because we're replacing 'fromInteger' with +a call to fromInteger. Reason: it allows commoning up of the fromInteger +calls, which wouldn't be possible if the desguarar made the application. + +The PostTcType in each branch records the type the overload literal is +found to have. + +\begin{code} -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module MatchLit) instance Eq (HsOverLit id) where - (HsIntegral i1 _ _) == (HsIntegral i2 _ _) = i1 == i2 - (HsFractional f1 _ _) == (HsFractional f2 _ _) = f1 == f2 - (HsIsString s1 _ _) == (HsIsString s2 _ _) = s1 == s2 - _ == _ = False + (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2 + +instance Eq OverLitVal where + (HsIntegral i1) == (HsIntegral i2) = i1 == i2 + (HsFractional f1) == (HsFractional f2) = f1 == f2 + (HsIsString s1) == (HsIsString s2) = s1 == s2 + _ == _ = False instance Ord (HsOverLit id) where - compare (HsIntegral i1 _ _) (HsIntegral i2 _ _) = i1 `compare` i2 - compare (HsIntegral _ _ _) (HsFractional _ _ _) = LT - compare (HsIntegral _ _ _) (HsIsString _ _ _) = LT - compare (HsFractional f1 _ _) (HsFractional f2 _ _) = f1 `compare` f2 - compare (HsFractional _ _ _) (HsIntegral _ _ _) = GT - compare (HsFractional _ _ _) (HsIsString _ _ _) = LT - compare (HsIsString s1 _ _) (HsIsString s2 _ _) = s1 `compare` s2 - compare (HsIsString _ _ _) (HsIntegral _ _ _) = GT - compare (HsIsString _ _ _) (HsFractional _ _ _) = GT + compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2 + +instance Ord OverLitVal where + compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 + compare (HsIntegral _) (HsFractional _) = LT + compare (HsIntegral _) (HsIsString _) = LT + compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2 + compare (HsFractional _) (HsIntegral _) = GT + compare (HsFractional _) (HsIsString _) = LT + compare (HsIsString s1) (HsIsString s2) = s1 `compare` s2 + compare (HsIsString _) (HsIntegral _) = GT + compare (HsIsString _) (HsFractional _) = GT \end{code} \begin{code} @@ -110,15 +143,19 @@ 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 "##" -- in debug mode, print the expression that it's resolved to, too instance OutputableBndr id => Outputable (HsOverLit id) where - ppr (HsIntegral i e _) = integer i <+> (ifPprDebug (parens (pprExpr e))) - ppr (HsFractional f e _) = rational f <+> (ifPprDebug (parens (pprExpr e))) - ppr (HsIsString s e _) = pprHsString s <+> (ifPprDebug (parens (pprExpr e))) + ppr (OverLit {ol_val=val, ol_witness=witness}) + = ppr val <+> (ifPprDebug (parens (pprExpr witness))) + +instance Outputable OverLitVal where + ppr (HsIntegral i) = integer i + ppr (HsFractional f) = ppr f + ppr (HsIsString s) = pprHsString s \end{code}