X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsLit.lhs;h=2cda10347982ebb11f741740f41f846dde156ff8;hp=edf08e37c9371d8c2a7efc41eb0b95bc5410336d;hb=6ddfe9b18d4d280676aab2fa797ddbe6f8a09d6b;hpb=90dc9026b091be5cca5da4c6cbd3713ecc493361 diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index edf08e3..2cda103 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -5,15 +5,20 @@ \section[HsLit]{Abstract syntax: source-language literals} \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} + module HsLit where #include "HsVersions.h" -import {-# SOURCE #-} HsExpr( SyntaxExpr ) +import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr ) +import BasicTypes ( FractionalLit(..) ) +import HsTypes ( PostTcType ) import Type ( Type ) import Outputable import FastString -import Ratio ( Rational ) + +import Data.Data \end{code} @@ -33,12 +38,14 @@ data HsLit | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, -- and from TRANSLATION | HsIntPrim Integer -- Unboxed Int + | 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 @@ -47,41 +54,84 @@ instance Eq HsLit where (HsStringPrim x1) == (HsStringPrim x2) = x1==x2 (HsInt x1) == (HsInt x2) = x1==x2 (HsIntPrim x1) == (HsIntPrim x2) = x1==x2 + (HsWordPrim x1) == (HsWordPrim x2) = x1==x2 (HsInteger x1 _) == (HsInteger x2 _) = x1==x2 (HsRat x1 _) == (HsRat x2 _) = x1==x2 (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 (HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2 - lit1 == lit2 = False + _ == _ = False data HsOverLit id -- An overloaded literal - = HsIntegral Integer (SyntaxExpr id) -- Integer-looking literals; - | HsFractional Rational (SyntaxExpr id) -- Frac-looking literals - | HsIsString FastString (SyntaxExpr id) -- 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 + = 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 - l1 == l2 = 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 f1 _) (HsIntegral _ _) = GT - compare (HsFractional f1 _) (HsIsString _ _) = LT - compare (HsIsString s1 _) (HsIsString s2 _) = s1 `compare` s2 - compare (HsIsString s1 _) (HsIntegral _ _) = GT - compare (HsIsString s1 _) (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} @@ -93,13 +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 (OverLit {ol_val=val, ol_witness=witness}) + = ppr val <+> (ifPprDebug (parens (pprExpr witness))) -instance Outputable (HsOverLit id) where - ppr (HsIntegral i _) = integer i - ppr (HsFractional f _) = rational f - ppr (HsIsString s _) = pprHsString s +instance Outputable OverLitVal where + ppr (HsIntegral i) = integer i + ppr (HsFractional f) = ppr f + ppr (HsIsString s) = pprHsString s \end{code}