{-# LANGUAGE CPP                  #-}
{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
                                      -- in module Language.Haskell.Syntax.Extension

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

-}

-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*

-- | Source-language literals
module Language.Haskell.Syntax.Lit where

#include "HsVersions.h"

import GHC.Prelude

import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsExpr )
import GHC.Types.Basic (PprPrec(..), topPrec )
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 Data.ByteString (ByteString)
import Data.Data hiding ( Fixity )

{-
************************************************************************
*                                                                      *
\subsection[HsLit]{Literals}
*                                                                      *
************************************************************************
-}

-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in
-- the following
-- Note [Trees that grow] in Language.Haskell.Syntax.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)

instance Eq (HsLit x) where
  (HsChar XHsChar x
_ Char
x1)       == :: HsLit x -> HsLit x -> Bool
== (HsChar XHsChar x
_ Char
x2)       = Char
x1forall a. Eq a => a -> a -> Bool
==Char
x2
  (HsCharPrim XHsCharPrim x
_ Char
x1)   == (HsCharPrim XHsCharPrim x
_ Char
x2)   = Char
x1forall a. Eq a => a -> a -> Bool
==Char
x2
  (HsString XHsString x
_ FastString
x1)     == (HsString XHsString x
_ FastString
x2)     = FastString
x1forall a. Eq a => a -> a -> Bool
==FastString
x2
  (HsStringPrim XHsStringPrim x
_ ByteString
x1) == (HsStringPrim XHsStringPrim x
_ ByteString
x2) = ByteString
x1forall a. Eq a => a -> a -> Bool
==ByteString
x2
  (HsInt XHsInt x
_ IntegralLit
x1)        == (HsInt XHsInt x
_ IntegralLit
x2)        = IntegralLit
x1forall a. Eq a => a -> a -> Bool
==IntegralLit
x2
  (HsIntPrim XHsIntPrim x
_ Integer
x1)    == (HsIntPrim XHsIntPrim x
_ Integer
x2)    = Integer
x1forall a. Eq a => a -> a -> Bool
==Integer
x2
  (HsWordPrim XHsWordPrim x
_ Integer
x1)   == (HsWordPrim XHsWordPrim x
_ Integer
x2)   = Integer
x1forall a. Eq a => a -> a -> Bool
==Integer
x2
  (HsInt64Prim XHsInt64Prim x
_ Integer
x1)  == (HsInt64Prim XHsInt64Prim x
_ Integer
x2)  = Integer
x1forall a. Eq a => a -> a -> Bool
==Integer
x2
  (HsWord64Prim XHsWord64Prim x
_ Integer
x1) == (HsWord64Prim XHsWord64Prim x
_ Integer
x2) = Integer
x1forall a. Eq a => a -> a -> Bool
==Integer
x2
  (HsInteger XHsInteger x
_ Integer
x1 Type
_)  == (HsInteger XHsInteger x
_ Integer
x2 Type
_)  = Integer
x1forall a. Eq a => a -> a -> Bool
==Integer
x2
  (HsRat XHsRat x
_ FractionalLit
x1 Type
_)      == (HsRat XHsRat x
_ FractionalLit
x2 Type
_)      = FractionalLit
x1forall a. Eq a => a -> a -> Bool
==FractionalLit
x2
  (HsFloatPrim XHsFloatPrim x
_ FractionalLit
x1)  == (HsFloatPrim XHsFloatPrim x
_ FractionalLit
x2)  = FractionalLit
x1forall a. Eq a => a -> a -> Bool
==FractionalLit
x2
  (HsDoublePrim XHsDoublePrim x
_ FractionalLit
x1) == (HsDoublePrim XHsDoublePrim x
_ FractionalLit
x2) = FractionalLit
x1forall a. Eq a => a -> a -> Bool
==FractionalLit
x2
  HsLit x
_                   == HsLit x
_                   = Bool
False

-- | Haskell Overloaded Literal
data HsOverLit p
  = OverLit {
      forall p. HsOverLit p -> XOverLit p
ol_ext :: (XOverLit p),
      forall p. HsOverLit p -> OverLitVal
ol_val :: OverLitVal,
      forall p. HsOverLit p -> HsExpr p
ol_witness :: HsExpr p}         -- Note [Overloaded literal witnesses]

  | XOverLit
      !(XXOverLit p)

-- 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 Typeable OverLitVal
OverLitVal -> DataType
OverLitVal -> Constr
(forall b. Data b => b -> b) -> OverLitVal -> OverLitVal
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> OverLitVal -> u
forall u. (forall d. Data d => d -> u) -> OverLitVal -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OverLitVal -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OverLitVal -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OverLitVal -> m OverLitVal
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OverLitVal -> m OverLitVal
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OverLitVal
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OverLitVal -> c OverLitVal
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OverLitVal)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c OverLitVal)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OverLitVal -> m OverLitVal
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OverLitVal -> m OverLitVal
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OverLitVal -> m OverLitVal
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OverLitVal -> m OverLitVal
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OverLitVal -> m OverLitVal
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OverLitVal -> m OverLitVal
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> OverLitVal -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> OverLitVal -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> OverLitVal -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> OverLitVal -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OverLitVal -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OverLitVal -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OverLitVal -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OverLitVal -> r
gmapT :: (forall b. Data b => b -> b) -> OverLitVal -> OverLitVal
$cgmapT :: (forall b. Data b => b -> b) -> OverLitVal -> OverLitVal
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c OverLitVal)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c OverLitVal)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OverLitVal)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OverLitVal)
dataTypeOf :: OverLitVal -> DataType
$cdataTypeOf :: OverLitVal -> DataType
toConstr :: OverLitVal -> Constr
$ctoConstr :: OverLitVal -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OverLitVal
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OverLitVal
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OverLitVal -> c OverLitVal
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OverLitVal -> c OverLitVal
Data

negateOverLitVal :: OverLitVal -> OverLitVal
negateOverLitVal :: OverLitVal -> OverLitVal
negateOverLitVal (HsIntegral IntegralLit
i) = IntegralLit -> OverLitVal
HsIntegral (IntegralLit -> IntegralLit
negateIntegralLit IntegralLit
i)
negateOverLitVal (HsFractional FractionalLit
f) = FractionalLit -> OverLitVal
HsFractional (FractionalLit -> FractionalLit
negateFractionalLit FractionalLit
f)
negateOverLitVal OverLitVal
_ = forall a. String -> a
panic String
"negateOverLitVal: argument is not a number"

{-
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 XOverLit p
_ OverLitVal
val1 HsExpr p
_) == :: HsOverLit p -> HsOverLit p -> Bool
== (OverLit XOverLit p
_ OverLitVal
val2 HsExpr p
_) = OverLitVal
val1 forall a. Eq a => a -> a -> Bool
== OverLitVal
val2
  (XOverLit  XXOverLit p
val1)   == (XOverLit  XXOverLit p
val2)   = XXOverLit p
val1 forall a. Eq a => a -> a -> Bool
== XXOverLit p
val2
  HsOverLit p
_ == HsOverLit p
_ = forall a. String -> a
panic String
"Eq HsOverLit"

instance Eq OverLitVal where
  (HsIntegral   IntegralLit
i1)   == :: OverLitVal -> OverLitVal -> Bool
== (HsIntegral   IntegralLit
i2)   = IntegralLit
i1 forall a. Eq a => a -> a -> Bool
== IntegralLit
i2
  (HsFractional FractionalLit
f1)   == (HsFractional FractionalLit
f2)   = FractionalLit
f1 forall a. Eq a => a -> a -> Bool
== FractionalLit
f2
  (HsIsString SourceText
_ FastString
s1)   == (HsIsString SourceText
_ FastString
s2)   = FastString
s1 forall a. Eq a => a -> a -> Bool
== FastString
s2
  OverLitVal
_                   == OverLitVal
_                   = Bool
False

instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where
  compare :: HsOverLit p -> HsOverLit p -> Ordering
compare (OverLit XOverLit p
_ OverLitVal
val1 HsExpr p
_) (OverLit XOverLit p
_ OverLitVal
val2 HsExpr p
_) = OverLitVal
val1 forall a. Ord a => a -> a -> Ordering
`compare` OverLitVal
val2
  compare (XOverLit  XXOverLit p
val1)   (XOverLit  XXOverLit p
val2)   = XXOverLit p
val1 forall a. Ord a => a -> a -> Ordering
`compare` XXOverLit p
val2
  compare HsOverLit p
_ HsOverLit p
_ = forall a. String -> a
panic String
"Ord HsOverLit"

instance Ord OverLitVal where
  compare :: OverLitVal -> OverLitVal -> Ordering
compare (HsIntegral IntegralLit
i1)     (HsIntegral IntegralLit
i2)     = IntegralLit
i1 forall a. Ord a => a -> a -> Ordering
`compare` IntegralLit
i2
  compare (HsIntegral IntegralLit
_)      (HsFractional FractionalLit
_)    = Ordering
LT
  compare (HsIntegral IntegralLit
_)      (HsIsString SourceText
_ FastString
_)    = Ordering
LT
  compare (HsFractional FractionalLit
f1)   (HsFractional FractionalLit
f2)   = FractionalLit
f1 forall a. Ord a => a -> a -> Ordering
`compare` FractionalLit
f2
  compare (HsFractional FractionalLit
_)    (HsIntegral   IntegralLit
_)    = Ordering
GT
  compare (HsFractional FractionalLit
_)    (HsIsString SourceText
_ FastString
_)    = Ordering
LT
  compare (HsIsString SourceText
_ FastString
s1)   (HsIsString SourceText
_ FastString
s2)   = FastString
s1 FastString -> FastString -> Ordering
`uniqCompareFS` FastString
s2
  compare (HsIsString SourceText
_ FastString
_)    (HsIntegral   IntegralLit
_)    = Ordering
GT
  compare (HsIsString SourceText
_ FastString
_)    (HsFractional FractionalLit
_)    = Ordering
GT

instance Outputable OverLitVal where
  ppr :: OverLitVal -> SDoc
ppr (HsIntegral IntegralLit
i)     = SourceText -> SDoc -> SDoc
pprWithSourceText (IntegralLit -> SourceText
il_text IntegralLit
i) (Integer -> SDoc
integer (IntegralLit -> Integer
il_value IntegralLit
i))
  ppr (HsFractional FractionalLit
f)   = forall a. Outputable a => a -> SDoc
ppr FractionalLit
f
  ppr (HsIsString SourceText
st FastString
s)  = SourceText -> SDoc -> SDoc
pprWithSourceText SourceText
st (FastString -> SDoc
pprHsString FastString
s)

-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs
-- to be parenthesized under precedence @p@.
hsLitNeedsParens :: PprPrec -> HsLit x -> Bool
hsLitNeedsParens :: forall x. PprPrec -> HsLit x -> Bool
hsLitNeedsParens PprPrec
p = HsLit x -> Bool
go
  where
    go :: HsLit x -> Bool
go (HsChar {})        = Bool
False
    go (HsCharPrim {})    = Bool
False
    go (HsString {})      = Bool
False
    go (HsStringPrim {})  = Bool
False
    go (HsInt XHsInt x
_ IntegralLit
x)        = PprPrec
p forall a. Ord a => a -> a -> Bool
> PprPrec
topPrec Bool -> Bool -> Bool
&& IntegralLit -> Bool
il_neg IntegralLit
x
    go (HsIntPrim XHsIntPrim x
_ Integer
x)    = PprPrec
p forall a. Ord a => a -> a -> Bool
> PprPrec
topPrec Bool -> Bool -> Bool
&& Integer
x forall a. Ord a => a -> a -> Bool
< Integer
0
    go (HsWordPrim {})    = Bool
False
    go (HsInt64Prim XHsInt64Prim x
_ Integer
x)  = PprPrec
p forall a. Ord a => a -> a -> Bool
> PprPrec
topPrec Bool -> Bool -> Bool
&& Integer
x forall a. Ord a => a -> a -> Bool
< Integer
0
    go (HsWord64Prim {})  = Bool
False
    go (HsInteger XHsInteger x
_ Integer
x Type
_)  = PprPrec
p forall a. Ord a => a -> a -> Bool
> PprPrec
topPrec Bool -> Bool -> Bool
&& Integer
x forall a. Ord a => a -> a -> Bool
< Integer
0
    go (HsRat XHsRat x
_ FractionalLit
x Type
_)      = PprPrec
p forall a. Ord a => a -> a -> Bool
> PprPrec
topPrec Bool -> Bool -> Bool
&& FractionalLit -> Bool
fl_neg FractionalLit
x
    go (HsFloatPrim XHsFloatPrim x
_ FractionalLit
x)  = PprPrec
p forall a. Ord a => a -> a -> Bool
> PprPrec
topPrec Bool -> Bool -> Bool
&& FractionalLit -> Bool
fl_neg FractionalLit
x
    go (HsDoublePrim XHsDoublePrim x
_ FractionalLit
x) = PprPrec
p forall a. Ord a => a -> a -> Bool
> PprPrec
topPrec Bool -> Bool -> Bool
&& FractionalLit -> Bool
fl_neg FractionalLit
x
    go (XLit XXLit x
_)           = Bool
False

-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal
-- @ol@ needs to be parenthesized under precedence @p@.
hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool
hsOverLitNeedsParens :: forall x. PprPrec -> HsOverLit x -> Bool
hsOverLitNeedsParens PprPrec
p (OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = OverLitVal
olv }) = OverLitVal -> Bool
go OverLitVal
olv
  where
    go :: OverLitVal -> Bool
    go :: OverLitVal -> Bool
go (HsIntegral IntegralLit
x)   = PprPrec
p forall a. Ord a => a -> a -> Bool
> PprPrec
topPrec Bool -> Bool -> Bool
&& IntegralLit -> Bool
il_neg IntegralLit
x
    go (HsFractional FractionalLit
x) = PprPrec
p forall a. Ord a => a -> a -> Bool
> PprPrec
topPrec Bool -> Bool -> Bool
&& FractionalLit -> Bool
fl_neg FractionalLit
x
    go (HsIsString {})  = Bool
False
hsOverLitNeedsParens PprPrec
_ (XOverLit { }) = Bool
False