summaryrefslogtreecommitdiff
path: root/compiler/GHC/Hs/Lit.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Hs/Lit.hs')
-rw-r--r--compiler/GHC/Hs/Lit.hs314
1 files changed, 314 insertions, 0 deletions
diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs
new file mode 100644
index 0000000000..ab30de87ac
--- /dev/null
+++ b/compiler/GHC/Hs/Lit.hs
@@ -0,0 +1,314 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[HsLit]{Abstract syntax: source-language literals}
+-}
+
+{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+ -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module GHC.Hs.Lit where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr )
+import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,
+ negateFractionalLit,SourceText(..),pprWithSourceText )
+import Type
+import Outputable
+import FastString
+import GHC.Hs.Extension
+
+import Data.ByteString (ByteString)
+import Data.Data hiding ( Fixity )
+
+{-
+************************************************************************
+* *
+\subsection[HsLit]{Literals}
+* *
+************************************************************************
+-}
+
+-- Note [Literal source text] in BasicTypes 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
+ -- @TcGenDeriv@, 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
+type instance XHsStringPrim (GhcPass _) = SourceText
+type instance XHsInt (GhcPass _) = NoExtField
+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 _) = NoExtField
+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]
+ ol_type :: Type }
+ deriving Data
+
+type instance XOverLit GhcPs = NoExtField
+type instance XOverLit GhcRn = Bool -- Note [ol_rebindable]
+type instance XOverLit GhcTc = OverLitTc
+
+type instance XXOverLit (GhcPass _) = NoExtCon
+
+-- Note [Literal source text] in BasicTypes 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
+overLitType (XOverLit nec) = noExtCon nec
+
+-- | Convert a literal from one index type to another, updating the annotations
+-- according to the relevant 'Convertable' instance
+convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b
+convertLit (HsChar a x) = (HsChar (convert a) x)
+convertLit (HsCharPrim a x) = (HsCharPrim (convert a) x)
+convertLit (HsString a x) = (HsString (convert a) x)
+convertLit (HsStringPrim a x) = (HsStringPrim (convert a) x)
+convertLit (HsInt a x) = (HsInt (convert a) x)
+convertLit (HsIntPrim a x) = (HsIntPrim (convert a) x)
+convertLit (HsWordPrim a x) = (HsWordPrim (convert a) x)
+convertLit (HsInt64Prim a x) = (HsInt64Prim (convert a) x)
+convertLit (HsWord64Prim a x) = (HsWord64Prim (convert a) x)
+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]
+~~~~~~~~~~~~~~~~~~~~
+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 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 MatchLit)
+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 `compare` s2
+ compare (HsIsString _ _) (HsIntegral _) = GT
+ compare (HsIsString _ _) (HsFractional _) = GT
+
+-- Instance specific to GhcPs, need the SourceText
+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 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 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 (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsOverLit p) where
+ ppr (OverLit {ol_val=val, ol_witness=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))
+ 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
+-- mainly for too reasons:
+-- * We do not want to expose their internal representation
+-- * The warnings become too messy
+pmPprHsLit :: HsLit (GhcPass x) -> SDoc
+pmPprHsLit (HsChar _ c) = pprHsChar c
+pmPprHsLit (HsCharPrim _ c) = pprHsChar c
+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
+pmPprHsLit (HsWordPrim _ w) = integer w
+pmPprHsLit (HsInt64Prim _ i) = integer i
+pmPprHsLit (HsWord64Prim _ w) = integer w
+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