diff options
Diffstat (limited to 'compiler/hsSyn/HsLit.hs')
| -rw-r--r-- | compiler/hsSyn/HsLit.hs | 132 |
1 files changed, 96 insertions, 36 deletions
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index 1044f9bca6..d1411bd750 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -8,7 +8,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder @@ -19,10 +18,12 @@ module HsLit where #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, negateFractionalLit,SourceText(..),pprWithSourceText ) -import Type ( Type ) +import Type import Outputable import FastString import HsExtension @@ -75,8 +76,22 @@ data HsLit x | HsDoublePrim (XHsDoublePrim x) FractionalLit -- ^ Unboxed Double -deriving instance (DataId x) => Data (HsLit x) + | XLit (XXLit x) +type instance XHsChar (GhcPass _) = SourceText +type instance XHsCharPrim (GhcPass _) = SourceText +type instance XHsString (GhcPass _) = SourceText +type instance XHsStringPrim (GhcPass _) = SourceText +type instance XHsInt (GhcPass _) = NoExt +type instance XHsIntPrim (GhcPass _) = SourceText +type instance XHsWordPrim (GhcPass _) = SourceText +type instance XHsInt64Prim (GhcPass _) = SourceText +type instance XHsWord64Prim (GhcPass _) = SourceText +type instance XHsInteger (GhcPass _) = SourceText +type instance XHsRat (GhcPass _) = NoExt +type instance XHsFloatPrim (GhcPass _) = NoExt +type instance XHsDoublePrim (GhcPass _) = NoExt +type instance XXLit (GhcPass _) = NoExt instance Eq (HsLit x) where (HsChar _ x1) == (HsChar _ x2) = x1==x2 @@ -97,11 +112,24 @@ instance Eq (HsLit x) where -- | Haskell Overloaded Literal data HsOverLit p = OverLit { - ol_val :: OverLitVal, - ol_rebindable :: PostRn p Bool, -- Note [ol_rebindable] - ol_witness :: HsExpr p, -- Note [Overloaded literal witnesses] - ol_type :: PostTc p Type } -deriving instance (DataId p, DataId p) => Data (HsOverLit p) + 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] + ol_type :: Type } + deriving Data + +type instance XOverLit GhcPs = NoExt +type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] +type instance XOverLit GhcTc = OverLitTc + +type instance XXOverLit (GhcPass _) = NoExt -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -117,8 +145,9 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" -overLitType :: HsOverLit p -> PostTc p Type -overLitType = ol_type +overLitType :: HsOverLit GhcTc -> Type +overLitType (OverLit (OverLitTc _ ty) _ _) = ty +overLitType XOverLit{} = panic "overLitType" -- | Convert a literal from one index type to another, updating the annotations -- according to the relevant 'Convertable' instance @@ -136,6 +165,7 @@ convertLit (HsInteger a x b) = (HsInteger (convert a) x b) convertLit (HsRat a x b) = (HsRat (convert a) x b) convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x) convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x) +convertLit (XLit a) = (XLit (convert a)) {- Note [ol_rebindable] @@ -169,8 +199,10 @@ found to have. -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module MatchLit) -instance Eq (HsOverLit p) where - (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2 +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 @@ -178,8 +210,10 @@ instance Eq OverLitVal where (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 _ == _ = False -instance Ord (HsOverLit p) where - compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2 +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 @@ -193,38 +227,33 @@ instance Ord OverLitVal where compare (HsIsString _ _) (HsFractional _) = GT -- Instance specific to GhcPs, need the SourceText -instance (SourceTextX x) => Outputable (HsLit x) where - ppr (HsChar st c) = pprWithSourceText (getSourceText st) (pprHsChar c) - ppr (HsCharPrim st c) - = pp_st_suffix (getSourceText st) primCharSuffix (pprPrimChar c) - ppr (HsString st s) - = pprWithSourceText (getSourceText st) (pprHsString s) - ppr (HsStringPrim st s) - = pprWithSourceText (getSourceText st) (pprHsBytes s) +instance p ~ GhcPass pass => Outputable (HsLit p) where + ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) + ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) + ppr (HsString st s) = pprWithSourceText st (pprHsString s) + ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) ppr (HsInt _ i) = pprWithSourceText (il_text i) (integer (il_value i)) - ppr (HsInteger st i _) = pprWithSourceText (getSourceText st) (integer i) + ppr (HsInteger st i _) = pprWithSourceText st (integer i) ppr (HsRat _ f _) = ppr f ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix - ppr (HsIntPrim st i) - = pprWithSourceText (getSourceText st) (pprPrimInt i) - ppr (HsWordPrim st w) - = pprWithSourceText (getSourceText st) (pprPrimWord w) - ppr (HsInt64Prim st i) - = pp_st_suffix (getSourceText st) primInt64Suffix (pprPrimInt64 i) - ppr (HsWord64Prim st w) - = pp_st_suffix (getSourceText st) primWord64Suffix (pprPrimWord64 w) + ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) + ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) + ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) + ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) + ppr (XLit x) = ppr x pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc pp_st_suffix NoSourceText _ doc = doc pp_st_suffix (SourceText st) suffix _ = text st <> suffix -- in debug mode, print the expression that it's resolved to, too -instance (SourceTextX p, OutputableBndrId p) +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsOverLit p) where ppr (OverLit {ol_val=val, ol_witness=witness}) - = ppr val <+> (ifPprDebug (parens (pprExpr witness))) + = ppr val <+> (whenPprDebug (parens (pprExpr witness))) + ppr (XOverLit x) = ppr x instance Outputable OverLitVal where ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) @@ -237,11 +266,10 @@ instance Outputable OverLitVal where -- mainly for too reasons: -- * We do not want to expose their internal representation -- * The warnings become too messy -pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc +pmPprHsLit :: HsLit (GhcPass x) -> SDoc pmPprHsLit (HsChar _ c) = pprHsChar c pmPprHsLit (HsCharPrim _ c) = pprHsChar c -pmPprHsLit (HsString st s) = pprWithSourceText (getSourceText st) - (pprHsString s) +pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s) pmPprHsLit (HsStringPrim _ s) = pprHsBytes s pmPprHsLit (HsInt _ i) = integer (il_value i) pmPprHsLit (HsIntPrim _ i) = integer i @@ -252,3 +280,35 @@ pmPprHsLit (HsInteger _ i _) = integer i pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d +pmPprHsLit (XLit x) = ppr x + +-- | @'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 |