{-# 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

{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, OutputableBndrId

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

-}

-- | Source-language literals
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( pprExpr )

import Language.Haskell.Syntax.Lit

import GHC.Types.SourceText
import GHC.Core.Type
import GHC.Utils.Outputable
import Language.Haskell.Syntax.Extension
import GHC.Hs.Extension

import Data.Data hiding ( Fixity )

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

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

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

type instance XOverLit GhcPs = NoExtField
type instance XOverLit GhcRn = Bool            -- Note [ol_rebindable]
type instance XOverLit GhcTc = OverLitTc

type instance XXOverLit (GhcPass _) = NoExtCon

overLitType :: HsOverLit GhcTc -> Type
overLitType :: HsOverLit GhcTc -> Type
overLitType (OverLit (OverLitTc Bool
_ Type
ty) OverLitVal
_ HsExpr GhcTc
_) = Type
ty

-- | Convert a literal from one index type to another
convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit :: forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit (HsChar XHsChar (GhcPass p1)
a Char
x)       = XHsChar (GhcPass p2) -> Char -> HsLit (GhcPass p2)
forall x. XHsChar x -> Char -> HsLit x
HsChar XHsChar (GhcPass p1)
XHsChar (GhcPass p2)
a Char
x
convertLit (HsCharPrim XHsCharPrim (GhcPass p1)
a Char
x)   = XHsCharPrim (GhcPass p2) -> Char -> HsLit (GhcPass p2)
forall x. XHsCharPrim x -> Char -> HsLit x
HsCharPrim XHsCharPrim (GhcPass p1)
XHsCharPrim (GhcPass p2)
a Char
x
convertLit (HsString XHsString (GhcPass p1)
a FastString
x)     = XHsString (GhcPass p2) -> FastString -> HsLit (GhcPass p2)
forall x. XHsString x -> FastString -> HsLit x
HsString XHsString (GhcPass p1)
XHsString (GhcPass p2)
a FastString
x
convertLit (HsStringPrim XHsStringPrim (GhcPass p1)
a ByteString
x) = XHsStringPrim (GhcPass p2) -> ByteString -> HsLit (GhcPass p2)
forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim XHsStringPrim (GhcPass p1)
XHsStringPrim (GhcPass p2)
a ByteString
x
convertLit (HsInt XHsInt (GhcPass p1)
a IntegralLit
x)        = XHsInt (GhcPass p2) -> IntegralLit -> HsLit (GhcPass p2)
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt XHsInt (GhcPass p1)
XHsInt (GhcPass p2)
a IntegralLit
x
convertLit (HsIntPrim XHsIntPrim (GhcPass p1)
a Integer
x)    = XHsIntPrim (GhcPass p2) -> Integer -> HsLit (GhcPass p2)
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim XHsIntPrim (GhcPass p1)
XHsIntPrim (GhcPass p2)
a Integer
x
convertLit (HsWordPrim XHsWordPrim (GhcPass p1)
a Integer
x)   = XHsWordPrim (GhcPass p2) -> Integer -> HsLit (GhcPass p2)
forall x. XHsWordPrim x -> Integer -> HsLit x
HsWordPrim XHsWordPrim (GhcPass p1)
XHsWordPrim (GhcPass p2)
a Integer
x
convertLit (HsInt64Prim XHsInt64Prim (GhcPass p1)
a Integer
x)  = XHsInt64Prim (GhcPass p2) -> Integer -> HsLit (GhcPass p2)
forall x. XHsInt64Prim x -> Integer -> HsLit x
HsInt64Prim XHsInt64Prim (GhcPass p1)
XHsInt64Prim (GhcPass p2)
a Integer
x
convertLit (HsWord64Prim XHsWord64Prim (GhcPass p1)
a Integer
x) = XHsWord64Prim (GhcPass p2) -> Integer -> HsLit (GhcPass p2)
forall x. XHsWord64Prim x -> Integer -> HsLit x
HsWord64Prim XHsWord64Prim (GhcPass p1)
XHsWord64Prim (GhcPass p2)
a Integer
x
convertLit (HsInteger XHsInteger (GhcPass p1)
a Integer
x Type
b)  = XHsInteger (GhcPass p2) -> Integer -> Type -> HsLit (GhcPass p2)
forall x. XHsInteger x -> Integer -> Type -> HsLit x
HsInteger XHsInteger (GhcPass p1)
XHsInteger (GhcPass p2)
a Integer
x Type
b
convertLit (HsRat XHsRat (GhcPass p1)
a FractionalLit
x Type
b)      = XHsRat (GhcPass p2) -> FractionalLit -> Type -> HsLit (GhcPass p2)
forall x. XHsRat x -> FractionalLit -> Type -> HsLit x
HsRat XHsRat (GhcPass p1)
XHsRat (GhcPass p2)
a FractionalLit
x Type
b
convertLit (HsFloatPrim XHsFloatPrim (GhcPass p1)
a FractionalLit
x)  = XHsFloatPrim (GhcPass p2) -> FractionalLit -> HsLit (GhcPass p2)
forall x. XHsFloatPrim x -> FractionalLit -> HsLit x
HsFloatPrim XHsFloatPrim (GhcPass p1)
XHsFloatPrim (GhcPass p2)
a FractionalLit
x
convertLit (HsDoublePrim XHsDoublePrim (GhcPass p1)
a FractionalLit
x) = XHsDoublePrim (GhcPass p2) -> FractionalLit -> HsLit (GhcPass p2)
forall x. XHsDoublePrim x -> FractionalLit -> HsLit x
HsDoublePrim XHsDoublePrim (GhcPass p1)
XHsDoublePrim (GhcPass p2)
a FractionalLit
x

{-
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
-}

-- Instance specific to GhcPs, need the SourceText
instance Outputable (HsLit (GhcPass p)) where
    ppr :: HsLit (GhcPass p) -> SDoc
ppr (HsChar XHsChar (GhcPass p)
st Char
c)       = SourceText -> SDoc -> SDoc
pprWithSourceText SourceText
XHsChar (GhcPass p)
st (Char -> SDoc
pprHsChar Char
c)
    ppr (HsCharPrim XHsCharPrim (GhcPass p)
st Char
c)   = SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix SourceText
XHsCharPrim (GhcPass p)
st SDoc
primCharSuffix (Char -> SDoc
pprPrimChar Char
c)
    ppr (HsString XHsString (GhcPass p)
st FastString
s)     = SourceText -> SDoc -> SDoc
pprWithSourceText SourceText
XHsString (GhcPass p)
st (FastString -> SDoc
pprHsString FastString
s)
    ppr (HsStringPrim XHsStringPrim (GhcPass p)
st ByteString
s) = SourceText -> SDoc -> SDoc
pprWithSourceText SourceText
XHsStringPrim (GhcPass p)
st (ByteString -> SDoc
pprHsBytes ByteString
s)
    ppr (HsInt XHsInt (GhcPass p)
_ IntegralLit
i)
      = SourceText -> SDoc -> SDoc
pprWithSourceText (IntegralLit -> SourceText
il_text IntegralLit
i) (Integer -> SDoc
integer (IntegralLit -> Integer
il_value IntegralLit
i))
    ppr (HsInteger XHsInteger (GhcPass p)
st Integer
i Type
_)  = SourceText -> SDoc -> SDoc
pprWithSourceText SourceText
XHsInteger (GhcPass p)
st (Integer -> SDoc
integer Integer
i)
    ppr (HsRat XHsRat (GhcPass p)
_ FractionalLit
f Type
_)       = FractionalLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr FractionalLit
f
    ppr (HsFloatPrim XHsFloatPrim (GhcPass p)
_ FractionalLit
f)   = FractionalLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr FractionalLit
f SDoc -> SDoc -> SDoc
<> SDoc
primFloatSuffix
    ppr (HsDoublePrim XHsDoublePrim (GhcPass p)
_ FractionalLit
d)  = FractionalLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr FractionalLit
d SDoc -> SDoc -> SDoc
<> SDoc
primDoubleSuffix
    ppr (HsIntPrim XHsIntPrim (GhcPass p)
st Integer
i)    = SourceText -> SDoc -> SDoc
pprWithSourceText SourceText
XHsIntPrim (GhcPass p)
st (Integer -> SDoc
pprPrimInt Integer
i)
    ppr (HsWordPrim XHsWordPrim (GhcPass p)
st Integer
w)   = SourceText -> SDoc -> SDoc
pprWithSourceText SourceText
XHsWordPrim (GhcPass p)
st (Integer -> SDoc
pprPrimWord Integer
w)
    ppr (HsInt64Prim XHsInt64Prim (GhcPass p)
st Integer
i)  = SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix SourceText
XHsInt64Prim (GhcPass p)
st SDoc
primInt64Suffix  (Integer -> SDoc
pprPrimInt64 Integer
i)
    ppr (HsWord64Prim XHsWord64Prim (GhcPass p)
st Integer
w) = SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix SourceText
XHsWord64Prim (GhcPass p)
st SDoc
primWord64Suffix (Integer -> SDoc
pprPrimWord64 Integer
w)

pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix SourceText
NoSourceText         SDoc
_ SDoc
doc = SDoc
doc
pp_st_suffix (SourceText String
st) SDoc
suffix SDoc
_   = String -> SDoc
text String
st SDoc -> SDoc -> SDoc
<> SDoc
suffix

-- in debug mode, print the expression that it's resolved to, too
instance OutputableBndrId p
       => Outputable (HsOverLit (GhcPass p)) where
  ppr :: HsOverLit (GhcPass p) -> SDoc
ppr (OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val=OverLitVal
val, ol_witness :: forall p. HsOverLit p -> HsExpr p
ol_witness=HsExpr (GhcPass p)
witness})
        = OverLitVal -> SDoc
forall a. Outputable a => a -> SDoc
ppr OverLitVal
val SDoc -> SDoc -> SDoc
<+> (SDoc -> SDoc
whenPprDebug (SDoc -> SDoc
parens (HsExpr (GhcPass p) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
HsExpr (GhcPass p) -> SDoc
pprExpr HsExpr (GhcPass p)
witness)))

-- | 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 :: forall (p :: Pass). HsLit (GhcPass p) -> SDoc
pmPprHsLit (HsChar XHsChar (GhcPass x)
_ Char
c)       = Char -> SDoc
pprHsChar Char
c
pmPprHsLit (HsCharPrim XHsCharPrim (GhcPass x)
_ Char
c)   = Char -> SDoc
pprHsChar Char
c
pmPprHsLit (HsString XHsString (GhcPass x)
st FastString
s)    = SourceText -> SDoc -> SDoc
pprWithSourceText SourceText
XHsString (GhcPass x)
st (FastString -> SDoc
pprHsString FastString
s)
pmPprHsLit (HsStringPrim XHsStringPrim (GhcPass x)
_ ByteString
s) = ByteString -> SDoc
pprHsBytes ByteString
s
pmPprHsLit (HsInt XHsInt (GhcPass x)
_ IntegralLit
i)        = Integer -> SDoc
integer (IntegralLit -> Integer
il_value IntegralLit
i)
pmPprHsLit (HsIntPrim XHsIntPrim (GhcPass x)
_ Integer
i)    = Integer -> SDoc
integer Integer
i
pmPprHsLit (HsWordPrim XHsWordPrim (GhcPass x)
_ Integer
w)   = Integer -> SDoc
integer Integer
w
pmPprHsLit (HsInt64Prim XHsInt64Prim (GhcPass x)
_ Integer
i)  = Integer -> SDoc
integer Integer
i
pmPprHsLit (HsWord64Prim XHsWord64Prim (GhcPass x)
_ Integer
w) = Integer -> SDoc
integer Integer
w
pmPprHsLit (HsInteger XHsInteger (GhcPass x)
_ Integer
i Type
_)  = Integer -> SDoc
integer Integer
i
pmPprHsLit (HsRat XHsRat (GhcPass x)
_ FractionalLit
f Type
_)      = FractionalLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr FractionalLit
f
pmPprHsLit (HsFloatPrim XHsFloatPrim (GhcPass x)
_ FractionalLit
f)  = FractionalLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr FractionalLit
f
pmPprHsLit (HsDoublePrim XHsDoublePrim (GhcPass x)
_ FractionalLit
d) = FractionalLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr FractionalLit
d