diff options
Diffstat (limited to 'compiler/GHC/Hs/Lit.hs')
| -rw-r--r-- | compiler/GHC/Hs/Lit.hs | 178 |
1 files changed, 12 insertions, 166 deletions
diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index 75ea3ef469..9aaadba24f 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -5,7 +5,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] - -- in module GHC.Hs.Extension + -- in module Language.Haskell.Syntax.Extension + +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, OutputableBndrId {- (c) The University of Glasgow 2006 @@ -14,22 +16,25 @@ -} -- | Source-language literals -module GHC.Hs.Lit where +module GHC.Hs.Lit + ( module Language.Haskell.Syntax.Lit + , module GHC.Hs.Lit + ) where #include "HsVersions.h" import GHC.Prelude -import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr ) -import GHC.Types.Basic (PprPrec(..), topPrec ) +import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) + +import Language.Haskell.Syntax.Lit + import GHC.Types.SourceText import GHC.Core.Type import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.FastString +import Language.Haskell.Syntax.Extension import GHC.Hs.Extension -import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) {- @@ -40,45 +45,6 @@ import Data.Data hiding ( Fixity ) ************************************************************************ -} --- Note [Literal source text] in GHC.Types.Basic for SourceText fields in --- the following --- Note [Trees that grow] in GHC.Hs.Extension for the Xxxxx fields in the following --- | Haskell Literal -data HsLit x - = HsChar (XHsChar x) {- SourceText -} Char - -- ^ Character - | HsCharPrim (XHsCharPrim x) {- SourceText -} Char - -- ^ Unboxed character - | HsString (XHsString x) {- SourceText -} FastString - -- ^ String - | HsStringPrim (XHsStringPrim x) {- SourceText -} !ByteString - -- ^ Packed bytes - | HsInt (XHsInt x) IntegralLit - -- ^ Genuinely an Int; arises from - -- "GHC.Tc.Deriv.Generate", and from TRANSLATION - | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer - -- ^ literal @Int#@ - | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer - -- ^ literal @Word#@ - | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer - -- ^ literal @Int64#@ - | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer - -- ^ literal @Word64#@ - | HsInteger (XHsInteger x) {- SourceText -} Integer Type - -- ^ Genuinely an integer; arises only - -- from TRANSLATION (overloaded - -- literals are done with HsOverLit) - | HsRat (XHsRat x) FractionalLit Type - -- ^ Genuinely a rational; arises only from - -- TRANSLATION (overloaded literals are - -- done with HsOverLit) - | HsFloatPrim (XHsFloatPrim x) FractionalLit - -- ^ Unboxed Float - | HsDoublePrim (XHsDoublePrim x) FractionalLit - -- ^ Unboxed Double - - | XLit !(XXLit x) - type instance XHsChar (GhcPass _) = SourceText type instance XHsCharPrim (GhcPass _) = SourceText type instance XHsString (GhcPass _) = SourceText @@ -94,32 +60,6 @@ type instance XHsFloatPrim (GhcPass _) = NoExtField type instance XHsDoublePrim (GhcPass _) = NoExtField type instance XXLit (GhcPass _) = NoExtCon -instance Eq (HsLit x) where - (HsChar _ x1) == (HsChar _ x2) = x1==x2 - (HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2 - (HsString _ x1) == (HsString _ x2) = x1==x2 - (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2 - (HsInt _ x1) == (HsInt _ x2) = x1==x2 - (HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2 - (HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2 - (HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2 - (HsWord64Prim _ x1) == (HsWord64Prim _ 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 - _ == _ = False - --- | Haskell Overloaded Literal -data HsOverLit p - = OverLit { - ol_ext :: (XOverLit p), - ol_val :: OverLitVal, - ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses] - - | XOverLit - !(XXOverLit p) - data OverLitTc = OverLitTc { ol_rebindable :: Bool, -- Note [ol_rebindable] @@ -132,20 +72,6 @@ type instance XOverLit GhcTc = OverLitTc type instance XXOverLit (GhcPass _) = NoExtCon --- Note [Literal source text] in GHC.Types.Basic for SourceText fields in --- the following --- | Overloaded Literal Value -data OverLitVal - = HsIntegral !IntegralLit -- ^ Integer-looking literals; - | HsFractional !FractionalLit -- ^ Frac-looking literals - | HsIsString !SourceText !FastString -- ^ String-looking literals - deriving Data - -negateOverLitVal :: OverLitVal -> OverLitVal -negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) -negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) -negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" - overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit (OverLitTc _ ty) _ _) = ty @@ -178,52 +104,8 @@ 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 HsExpr 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 desugarer made the application. - -The PostTcType in each branch records the type the overload literal is -found to have. -} --- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) -instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where - (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2 - (XOverLit val1) == (XOverLit val2) = val1 == val2 - _ == _ = panic "Eq HsOverLit" - -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 (XXOverLit p)) => Ord (HsOverLit p) where - compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2 - compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2 - compare _ _ = panic "Ord HsOverLit" - -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 `uniqCompareFS` s2 - compare (HsIsString _ _) (HsIntegral _) = GT - compare (HsIsString _ _) (HsFractional _) = GT - -- Instance specific to GhcPs, need the SourceText instance Outputable (HsLit (GhcPass p)) where ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) @@ -251,11 +133,6 @@ instance OutputableBndrId p ppr (OverLit {ol_val=val, ol_witness=witness}) = ppr val <+> (whenPprDebug (parens (pprExpr witness))) -instance Outputable OverLitVal where - ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) - ppr (HsFractional f) = ppr f - ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) - -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern -- match warnings. All are printed the same (i.e., without hashes if they are -- primitive and not wrapped in constructors if they are boxed). This happens @@ -276,34 +153,3 @@ pmPprHsLit (HsInteger _ i _) = integer i pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d - --- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs --- to be parenthesized under precedence @p@. -hsLitNeedsParens :: PprPrec -> HsLit x -> Bool -hsLitNeedsParens p = go - where - go (HsChar {}) = False - go (HsCharPrim {}) = False - go (HsString {}) = False - go (HsStringPrim {}) = False - go (HsInt _ x) = p > topPrec && il_neg x - go (HsIntPrim _ x) = p > topPrec && x < 0 - go (HsWordPrim {}) = False - go (HsInt64Prim _ x) = p > topPrec && x < 0 - go (HsWord64Prim {}) = False - go (HsInteger _ x _) = p > topPrec && x < 0 - go (HsRat _ x _) = p > topPrec && fl_neg x - go (HsFloatPrim _ x) = p > topPrec && fl_neg x - go (HsDoublePrim _ x) = p > topPrec && fl_neg x - go (XLit _) = False - --- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal --- @ol@ needs to be parenthesized under precedence @p@. -hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool -hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv - where - go :: OverLitVal -> Bool - go (HsIntegral x) = p > topPrec && il_neg x - go (HsFractional x) = p > topPrec && fl_neg x - go (HsIsString {}) = False -hsOverLitNeedsParens _ (XOverLit { }) = False |