{-# OPTIONS_HADDOCK not-home #-} -- we want users to import Language.Haskell.TH.Syntax instead
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}

-- | This module gives the definition of the 'Lift' class.
--
-- This is an internal module.
-- Please import "Language.Haskell.TH" or "Language.Haskell.TH.Syntax" instead!

module GHC.Internal.TH.Lift
  ( Lift(..)
  -- * Generic Lift implementations
  , dataToQa
  , dataToExpQ
  , liftData
  , dataToPatQ
  -- * Wired-in names
  , liftString
  , trueName
  , falseName
  , nothingName
  , justName
  , leftName
  , rightName
  , nonemptyName
  )
  where

import GHC.Internal.TH.Syntax
import qualified GHC.Internal.TH.Lib as Lib (litE)  -- See wrinkle (W4) of Note [Tracking dependencies on primitives]
import GHC.Internal.Lexeme ( startsVarSym, startsVarId )

import GHC.Internal.Data.Either
import GHC.Internal.Type.Reflection
import GHC.Internal.Data.Bool
import GHC.Internal.Base hiding (Type, Module, inline)
import GHC.Internal.Data.Foldable
import GHC.Internal.Integer
import GHC.Internal.Real
import GHC.Internal.Word
import GHC.Internal.Int
import GHC.Internal.Data.Data hiding (Fixity)
import GHC.Internal.Natural
import GHC.Internal.ForeignPtr

-- | A 'Lift' instance can have any of its values turned into a Template
-- Haskell expression. This is needed when a value used within a Template
-- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or
-- @[|| ... ||]@) but not at the top level. As an example:
--
-- > add1 :: Int -> Code Q Int
-- > add1 x = [|| x + 1 ||]
--
-- Template Haskell has no way of knowing what value @x@ will take on at
-- splice-time, so it requires the type of @x@ to be an instance of 'Lift'.
--
-- A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@
-- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices.
-- It is additionally expected that @'lift' x ≡ 'unTypeCode' ('liftTyped' x)@.
--
-- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@
-- GHC language extension:
--
-- > {-# LANGUAGE DeriveLift #-}
-- > module Foo where
-- >
-- > import Language.Haskell.TH.Syntax
-- >
-- > data Bar a = Bar1 a (Bar a) | Bar2 String
-- >   deriving Lift
--
-- Representation-polymorphic since /template-haskell-2.16.0.0/.
class Lift (t :: TYPE r) where
  -- | Turn a value into a Template Haskell expression, suitable for use in
  -- a splice.
  lift :: Quote m => t -> m Exp
  default lift :: (r ~ ('BoxedRep 'Lifted), Quote m) => t -> m Exp
  lift = Code m t -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode (Code m t -> m Exp) -> (t -> Code m t) -> t -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Code m t
forall t (m :: * -> *). (Lift t, Quote m) => t -> Code m t
forall (m :: * -> *). Quote m => t -> Code m t
liftTyped

  -- | Turn a value into a Template Haskell typed expression, suitable for use
  -- in a typed splice.
  --
  -- @since template-haskell-2.16.0.0
  liftTyped :: Quote m => t -> Code m t

-----------------------------------------------------
--
--      Manual instances for lifting to Literals
--
-----------------------------------------------------

-- If you add any instances here, consider updating test th/TH_Lift
instance Lift Integer where
  liftTyped :: forall (m :: * -> *). Quote m => Integer -> Code m Integer
liftTyped Integer
x = m Exp -> Code m Integer
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Integer -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Integer -> m Exp
lift Integer
x)
  lift :: forall (m :: * -> *). Quote m => Integer -> m Exp
lift Integer
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
x))

instance Lift Int where
  liftTyped :: forall (m :: * -> *). Quote m => Int -> Code m Int
liftTyped Int
x = m Exp -> Code m Int
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Int -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int -> m Exp
lift Int
x)
  lift :: forall (m :: * -> *). Quote m => Int -> m Exp
lift Int
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x)))

-- | @since template-haskell-2.16.0.0
instance Lift Int# where
  liftTyped :: forall (m :: * -> *). Quote m => Int# -> Code m Int#
liftTyped Int#
x = m Exp -> Code m Int#
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Int# -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int# -> m Exp
lift Int#
x)
  lift :: forall (m :: * -> *). Quote m => Int# -> m Exp
lift Int#
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntPrimL (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int# -> Int
I# Int#
x))))

instance Lift Int8 where
  liftTyped :: forall (m :: * -> *). Quote m => Int8 -> Code m Int8
liftTyped Int8
x = m Exp -> Code m Int8
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Int8 -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int8 -> m Exp
lift Int8
x)
  lift :: forall (m :: * -> *). Quote m => Int8 -> m Exp
lift Int8
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Int8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
x)))

instance Lift Int16 where
  liftTyped :: forall (m :: * -> *). Quote m => Int16 -> Code m Int16
liftTyped Int16
x = m Exp -> Code m Int16
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Int16 -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int16 -> m Exp
lift Int16
x)
  lift :: forall (m :: * -> *). Quote m => Int16 -> m Exp
lift Int16
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Int16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
x)))

instance Lift Int32 where
  liftTyped :: forall (m :: * -> *). Quote m => Int32 -> Code m Int32
liftTyped Int32
x = m Exp -> Code m Int32
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Int32 -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int32 -> m Exp
lift Int32
x)
  lift :: forall (m :: * -> *). Quote m => Int32 -> m Exp
lift Int32
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
x)))

instance Lift Int64 where
  liftTyped :: forall (m :: * -> *). Quote m => Int64 -> Code m Int64
liftTyped Int64
x = m Exp -> Code m Int64
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Int64 -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int64 -> m Exp
lift Int64
x)
  lift :: forall (m :: * -> *). Quote m => Int64 -> m Exp
lift Int64
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
x)))

-- | @since template-haskell-2.16.0.0
instance Lift Word# where
  liftTyped :: forall (m :: * -> *). Quote m => Word# -> Code m Word#
liftTyped Word#
x = m Exp -> Code m Word#
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Word# -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word# -> m Exp
lift Word#
x)
  lift :: forall (m :: * -> *). Quote m => Word# -> m Exp
lift Word#
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
WordPrimL (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word# -> Word
W# Word#
x))))

instance Lift Word where
  liftTyped :: forall (m :: * -> *). Quote m => Word -> Code m Word
liftTyped Word
x = m Exp -> Code m Word
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Word -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word -> m Exp
lift Word
x)
  lift :: forall (m :: * -> *). Quote m => Word -> m Exp
lift Word
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x)))

instance Lift Word8 where
  liftTyped :: forall (m :: * -> *). Quote m => Word8 -> Code m Word8
liftTyped Word8
x = m Exp -> Code m Word8
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Word8 -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word8 -> m Exp
lift Word8
x)
  lift :: forall (m :: * -> *). Quote m => Word8 -> m Exp
lift Word8
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x)))

instance Lift Word16 where
  liftTyped :: forall (m :: * -> *). Quote m => Word16 -> Code m Word16
liftTyped Word16
x = m Exp -> Code m Word16
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Word16 -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word16 -> m Exp
lift Word16
x)
  lift :: forall (m :: * -> *). Quote m => Word16 -> m Exp
lift Word16
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x)))

instance Lift Word32 where
  liftTyped :: forall (m :: * -> *). Quote m => Word32 -> Code m Word32
liftTyped Word32
x = m Exp -> Code m Word32
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Word32 -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word32 -> m Exp
lift Word32
x)
  lift :: forall (m :: * -> *). Quote m => Word32 -> m Exp
lift Word32
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x)))

instance Lift Word64 where
  liftTyped :: forall (m :: * -> *). Quote m => Word64 -> Code m Word64
liftTyped Word64
x = m Exp -> Code m Word64
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Word64 -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word64 -> m Exp
lift Word64
x)
  lift :: forall (m :: * -> *). Quote m => Word64 -> m Exp
lift Word64
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x)))

instance Lift Natural where
  liftTyped :: forall (m :: * -> *). Quote m => Natural -> Code m Natural
liftTyped Natural
x = m Exp -> Code m Natural
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Natural -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Natural -> m Exp
lift Natural
x)
  lift :: forall (m :: * -> *). Quote m => Natural -> m Exp
lift Natural
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
x)))

instance Integral a => Lift (Ratio a) where
  liftTyped :: forall (m :: * -> *). Quote m => Ratio a -> Code m (Ratio a)
liftTyped Ratio a
x = m Exp -> Code m (Ratio a)
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Ratio a -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Ratio a -> m Exp
lift Ratio a
x)
  lift :: forall (m :: * -> *). Quote m => Ratio a -> m Exp
lift Ratio a
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Rational -> Lit
RationalL (Ratio a -> Rational
forall a. Real a => a -> Rational
toRational Ratio a
x)))

instance Lift Float where
  liftTyped :: forall (m :: * -> *). Quote m => Float -> Code m Float
liftTyped Float
x = m Exp -> Code m Float
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Float -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Float -> m Exp
lift Float
x)
  lift :: forall (m :: * -> *). Quote m => Float -> m Exp
lift Float
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Rational -> Lit
RationalL (Float -> Rational
forall a. Real a => a -> Rational
toRational Float
x)))

-- | @since template-haskell-2.16.0.0
instance Lift Float# where
  liftTyped :: forall (m :: * -> *). Quote m => Float# -> Code m Float#
liftTyped Float#
x = m Exp -> Code m Float#
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Float# -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Float# -> m Exp
lift Float#
x)
  lift :: forall (m :: * -> *). Quote m => Float# -> m Exp
lift Float#
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Rational -> Lit
FloatPrimL (Float -> Rational
forall a. Real a => a -> Rational
toRational (Float# -> Float
F# Float#
x))))

instance Lift Double where
  liftTyped :: forall (m :: * -> *). Quote m => Double -> Code m Double
liftTyped Double
x = m Exp -> Code m Double
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Double -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Double -> m Exp
lift Double
x)
  lift :: forall (m :: * -> *). Quote m => Double -> m Exp
lift Double
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Rational -> Lit
RationalL (Double -> Rational
forall a. Real a => a -> Rational
toRational Double
x)))

-- | @since template-haskell-2.16.0.0
instance Lift Double# where
  liftTyped :: forall (m :: * -> *). Quote m => Double# -> Code m Double#
liftTyped Double#
x = m Exp -> Code m Double#
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Double# -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Double# -> m Exp
lift Double#
x)
  lift :: forall (m :: * -> *). Quote m => Double# -> m Exp
lift Double#
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Rational -> Lit
DoublePrimL (Double -> Rational
forall a. Real a => a -> Rational
toRational (Double# -> Double
D# Double#
x))))

instance Lift Char where
  liftTyped :: forall (m :: * -> *). Quote m => Char -> Code m Char
liftTyped Char
x = m Exp -> Code m Char
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Char -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Char -> m Exp
lift Char
x)
  lift :: forall (m :: * -> *). Quote m => Char -> m Exp
lift Char
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Char -> Lit
CharL Char
x))

-- | @since template-haskell-2.16.0.0
instance Lift Char# where
  liftTyped :: forall (m :: * -> *). Quote m => Char# -> Code m Char#
liftTyped Char#
x = m Exp -> Code m Char#
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Char# -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Char# -> m Exp
lift Char#
x)
  lift :: forall (m :: * -> *). Quote m => Char# -> m Exp
lift Char#
x = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE (Char -> Lit
CharPrimL (Char# -> Char
C# Char#
x)))

-- | Produces an 'Addr#' literal from the NUL-terminated C-string starting at
-- the given memory address.
--
-- @since template-haskell-2.16.0.0
instance Lift Addr# where
  liftTyped :: forall (m :: * -> *). Quote m => Addr# -> Code m Addr#
liftTyped Addr#
x = m Exp -> Code m Addr#
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Addr# -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Addr# -> m Exp
lift Addr#
x)
  lift :: forall (m :: * -> *). Quote m => Addr# -> m Exp
lift Addr#
x
    = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE ([Word8] -> Lit
StringPrimL ((Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) (Addr# -> [Char]
unpackCString# Addr#
x))))

instance Lift a => Lift [a] where
  liftTyped :: forall (m :: * -> *). Quote m => [a] -> Code m [a]
liftTyped [a]
x = m Exp -> Code m [a]
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce ([a] -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => [a] -> m Exp
lift [a]
x)
  lift :: forall (m :: * -> *). Quote m => [a] -> m Exp
lift [a]
xs = do { xs' <- (a -> m Exp) -> [a] -> m [Exp]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => a -> m Exp
lift [a]
xs; return (ListE xs') }

liftString :: Quote m => String -> m Exp
-- Used in GHC.Tc.Gen.Expr to short-circuit the lifting for strings
liftString :: forall (m :: * -> *). Quote m => [Char] -> m Exp
liftString [Char]
s = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE ([Char] -> Lit
StringL [Char]
s))

-- TH has a special form for literal strings,
-- which we should take advantage of.
-- NB: the lhs of the rule has no args, so that
--     the rule will apply to a 'lift' all on its own
--     which happens to be the way the type checker
--     creates it.
-- SG: This RULE is tested by T3600.
--     In #24983 I advocated defining an overlapping instance
--     to replace this RULE. However, doing so breaks drv023
--     which would need to declare an instance derived from `Lift @[a]` as
--     incoherent. So this RULE it is.
{-# RULES "TH:liftString" lift = liftString #-}

-----------------------------------------------------
--
--      Derived instances for base data types
--
-----------------------------------------------------

deriving instance Lift Bool
deriving instance Lift a => Lift (Maybe a)
deriving instance (Lift a, Lift b) => Lift (Either a b)
-- | @since template-haskell-2.15.0.0
deriving instance Lift a => Lift (NonEmpty a)
-- | @since template-haskell-2.15.0.0
deriving instance Lift Void
deriving instance Lift ()
deriving instance (Lift a, Lift b)
      => Lift (a, b)
deriving instance (Lift a, Lift b, Lift c)
      => Lift (a, b, c)
deriving instance (Lift a, Lift b, Lift c, Lift d)
      => Lift (a, b, c, d)
deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e)
      => Lift (a, b, c, d, e)
deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
      => Lift (a, b, c, d, e, f)
deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
      => Lift (a, b, c, d, e, f, g)
-- | @since template-haskell-2.16.0.0
deriving instance Lift (# #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a)
      => Lift (# a #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b)
      => Lift (# a, b #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b, Lift c)
      => Lift (# a, b, c #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b, Lift c, Lift d)
      => Lift (# a, b, c, d #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e)
      => Lift (# a, b, c, d, e #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
      => Lift (# a, b, c, d, e, f #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
      => Lift (# a, b, c, d, e, f, g #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b) => Lift (# a | b #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b, Lift c)
      => Lift (# a | b | c #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b, Lift c, Lift d)
      => Lift (# a | b | c | d #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e)
      => Lift (# a | b | c | d | e #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
      => Lift (# a | b | c | d | e | f #)
-- | @since template-haskell-2.16.0.0
deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
      => Lift (# a | b | c | d | e | f | g #)

trueName, falseName :: Name
trueName :: Name
trueName  = 'True
falseName :: Name
falseName = 'False

nothingName, justName :: Name
nothingName :: Name
nothingName = 'Nothing
justName :: Name
justName    = 'Just

leftName, rightName :: Name
leftName :: Name
leftName  = 'Left
rightName :: Name
rightName = 'Right

nonemptyName :: Name
nonemptyName :: Name
nonemptyName = '(:|)

-----------------------------------------------------
--
--              Lifting the TH AST
--
-----------------------------------------------------

-- | @since template-haskell-2.22.1.0
deriving instance Lift Loc
-- | @since template-haskell-2.22.1.0
deriving instance Lift DocLoc
-- | @since template-haskell-2.22.1.0
deriving instance Lift ModName
-- | @since template-haskell-2.22.1.0
deriving instance Lift GHC.Internal.TH.Syntax.Module
-- | @since template-haskell-2.22.1.0
deriving instance Lift NameSpace
-- | @since template-haskell-2.22.1.0
deriving instance Lift NamespaceSpecifier
-- | @since template-haskell-2.22.1.0
deriving instance Lift PkgName
-- | @since template-haskell-2.22.1.0
deriving instance Lift NameFlavour
-- | @since template-haskell-2.22.1.0
deriving instance Lift OccName
-- | @since template-haskell-2.22.1.0
deriving instance Lift Name
-- | @since template-haskell-2.22.1.0
deriving instance Lift NameIs
-- | @since template-haskell-2.22.1.0
deriving instance Lift Specificity
-- | @since template-haskell-2.22.1.0
deriving instance Lift BndrVis
-- | @since template-haskell-2.22.1.0
deriving instance Lift a => Lift (TyVarBndr a)
-- | @since template-haskell-2.22.1.0
deriving instance Lift TyLit
-- | @since template-haskell-2.22.1.0
deriving instance Lift Type
-- | @since template-haskell-2.22.1.0
instance Lift Bytes where
  liftTyped :: forall (m :: * -> *). Quote m => Bytes -> Code m Bytes
liftTyped Bytes
x = m Exp -> Code m Bytes
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (Bytes -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Bytes -> m Exp
lift Bytes
x)
  lift :: forall (m :: * -> *). Quote m => Bytes -> m Exp
lift bytes :: Bytes
bytes@Bytes{} = -- See Note [Why FinalPtr]
    [| Bytes
      { bytesPtr = ForeignPtr $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
Lib.litE (Bytes -> Lit
BytesPrimL Bytes
bytes)) FinalPtr
      , bytesOffset = 0
      , bytesSize = $(Word -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word -> m Exp
lift (Bytes -> Word
bytesSize Bytes
bytes))
      }
    |]
-- | @since template-haskell-2.22.1.0
deriving instance Lift Lit
-- | @since template-haskell-2.22.1.0
deriving instance Lift Pat
-- | @since template-haskell-2.22.1.0
deriving instance Lift Clause
-- | @since template-haskell-2.22.1.0
deriving instance Lift DerivClause
-- | @since template-haskell-2.22.1.0
deriving instance Lift DerivStrategy
-- | @since template-haskell-2.22.1.0
deriving instance Lift Overlap
-- | @since template-haskell-2.22.1.0
deriving instance Lift FunDep
-- | @since template-haskell-2.22.1.0
deriving instance Lift Safety
-- | @since template-haskell-2.22.1.0
deriving instance Lift Callconv
-- | @since template-haskell-2.22.1.0
deriving instance Lift Foreign
-- | @since template-haskell-2.22.1.0
deriving instance Lift ForeignSrcLang
-- | @since template-haskell-2.22.1.0
deriving instance Lift FixityDirection
-- | @since template-haskell-2.22.1.0
deriving instance Lift Fixity
-- | @since template-haskell-2.22.1.0
deriving instance Lift Inline
-- | @since template-haskell-2.22.1.0
deriving instance Lift RuleMatch
-- | @since template-haskell-2.22.1.0
deriving instance Lift Phases
-- | @since template-haskell-2.22.1.0
deriving instance Lift RuleBndr
-- | @since template-haskell-2.22.1.0
deriving instance Lift AnnTarget
-- | @since template-haskell-2.22.1.0
deriving instance Lift Pragma
-- | @since template-haskell-2.22.1.0
deriving instance Lift SourceStrictness
-- | @since template-haskell-2.22.1.0
deriving instance Lift SourceUnpackedness
-- | @since template-haskell-2.22.1.0
deriving instance Lift DecidedStrictness
-- | @since template-haskell-2.22.1.0
deriving instance Lift Bang
-- | @since template-haskell-2.22.1.0
deriving instance Lift Con
-- | @since template-haskell-2.22.1.0
deriving instance Lift TySynEqn
-- | @since template-haskell-2.22.1.0
deriving instance Lift FamilyResultSig
-- | @since template-haskell-2.22.1.0
deriving instance Lift InjectivityAnn
-- | @since template-haskell-2.22.1.0
deriving instance Lift TypeFamilyHead
-- | @since template-haskell-2.22.1.0
deriving instance Lift Role
-- | @since template-haskell-2.22.1.0
deriving instance Lift PatSynArgs
-- | @since template-haskell-2.22.1.0
deriving instance Lift PatSynDir
-- | @since template-haskell-2.22.1.0
deriving instance Lift Dec
-- | @since template-haskell-2.22.1.0
deriving instance Lift Range
-- | @since template-haskell-2.22.1.0
deriving instance Lift Exp
-- | @since template-haskell-2.22.1.0
instance Lift (TExp a) where
  lift :: forall (m :: * -> *). Quote m => TExp a -> m Exp
lift (TExp Exp
e) = [| TExp $(Exp -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Exp -> m Exp
lift Exp
e) |]
  liftTyped :: forall (m :: * -> *). Quote m => TExp a -> Code m (TExp a)
liftTyped = m Exp -> Code m (TExp a)
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (m Exp -> Code m (TExp a))
-> (TExp a -> m Exp) -> TExp a -> Code m (TExp a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TExp a -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => TExp a -> m Exp
lift
-- | @since template-haskell-2.22.1.0
deriving instance Lift Match
-- | @since template-haskell-2.22.1.0
deriving instance Lift Guard
-- | @since template-haskell-2.22.1.0
deriving instance Lift Stmt
-- | @since template-haskell-2.22.1.0
deriving instance Lift Body
-- | @since template-haskell-2.22.1.0
deriving instance Lift Info
-- | @since template-haskell-2.22.1.0
deriving instance Lift AnnLookup
-- | @since template-haskell-2.22.1.0
deriving instance Lift Extension

-----------------------------------------------------
--
--              Generic Lift implementations
--
-----------------------------------------------------

-- | 'dataToQa' is an internal utility function for constructing generic
-- conversion functions from types with 'Data' instances to various
-- quasi-quoting representations.  See the source of 'dataToExpQ' and
-- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@
-- and @appQ@ are overloadable to account for different syntax for
-- expressions and patterns; @antiQ@ allows you to override type-specific
-- cases, a common usage is just @const Nothing@, which results in
-- no overloading.
dataToQa  ::  forall m a k q. (Quote m, Data a)
          =>  (Name -> k)
          ->  (Lit -> m q)
          ->  (k -> [m q] -> m q)
          ->  (forall b . Data b => b -> Maybe (m q))
          ->  a
          ->  m q
dataToQa :: forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> k
mkCon Lit -> m q
mkLit k -> [m q] -> m q
appCon forall b. Data b => b -> Maybe (m q)
antiQ a
t =
    case a -> Maybe (m q)
forall b. Data b => b -> Maybe (m q)
antiQ a
t of
      Maybe (m q)
Nothing ->
          case Constr -> ConstrRep
constrRep Constr
constr of
            AlgConstr Int
_ ->
                k -> [m q] -> m q
appCon (Name -> k
mkCon Name
funOrConName) [m q]
conArgs
              where
                funOrConName :: Name
                funOrConName :: Name
funOrConName =
                    case Constr -> [Char]
showConstr Constr
constr of
                      [Char]
"(:)"       -> OccName -> NameFlavour -> Name
Name ([Char] -> OccName
mkOccName [Char]
":")
                                          (NameSpace -> PkgName -> ModName -> NameFlavour
NameG NameSpace
DataName
                                                ([Char] -> PkgName
mkPkgName [Char]
"ghc-prim")
                                                ([Char] -> ModName
mkModName [Char]
"GHC.Types"))
                      con :: [Char]
con@[Char]
"[]"    -> OccName -> NameFlavour -> Name
Name ([Char] -> OccName
mkOccName [Char]
con)
                                          (NameSpace -> PkgName -> ModName -> NameFlavour
NameG NameSpace
DataName
                                                ([Char] -> PkgName
mkPkgName [Char]
"ghc-prim")
                                                ([Char] -> ModName
mkModName [Char]
"GHC.Types"))
                      con :: [Char]
con@(Char
'(':[Char]
_) -> OccName -> NameFlavour -> Name
Name ([Char] -> OccName
mkOccName [Char]
con)
                                          (NameSpace -> PkgName -> ModName -> NameFlavour
NameG NameSpace
DataName
                                                ([Char] -> PkgName
mkPkgName [Char]
"ghc-prim")
                                                ([Char] -> ModName
mkModName [Char]
"GHC.Tuple"))

                      -- Tricky case: see Note [Data for non-algebraic types]
                      fun :: [Char]
fun@(Char
x:[Char]
_)   | Char -> Bool
startsVarSym Char
x Bool -> Bool -> Bool
|| Char -> Bool
startsVarId Char
x
                                  -> [Char] -> [Char] -> [Char] -> Name
mkNameG_v [Char]
tyconPkg [Char]
tyconMod [Char]
fun
                      [Char]
con         -> [Char] -> [Char] -> [Char] -> Name
mkNameG_d [Char]
tyconPkg [Char]
tyconMod [Char]
con

                  where
                    tycon :: TyCon
                    tycon :: TyCon
tycon = (TypeRep a -> TyCon
forall {k} (a :: k). TypeRep a -> TyCon
typeRepTyCon (TypeRep a -> TyCon) -> (a -> TypeRep a) -> a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep a
forall a. Typeable a => a -> TypeRep a
typeOf) a
t

                    tyconPkg, tyconMod :: String
                    tyconPkg :: [Char]
tyconPkg = TyCon -> [Char]
tyConPackage TyCon
tycon
                    tyconMod :: [Char]
tyconMod = TyCon -> [Char]
tyConModule  TyCon
tycon

                conArgs :: [m q]
                conArgs :: [m q]
conArgs = (forall d. Data d => d -> m q) -> a -> [m q]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> a -> [u]
gmapQ ((Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> d
-> m q
forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> k
mkCon Lit -> m q
mkLit k -> [m q] -> m q
appCon b -> Maybe (m q)
forall b. Data b => b -> Maybe (m q)
antiQ) a
t
            IntConstr Integer
n ->
                Lit -> m q
mkLit (Lit -> m q) -> Lit -> m q
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
n
            FloatConstr Rational
n ->
                Lit -> m q
mkLit (Lit -> m q) -> Lit -> m q
forall a b. (a -> b) -> a -> b
$ Rational -> Lit
RationalL Rational
n
            CharConstr Char
c ->
                Lit -> m q
mkLit (Lit -> m q) -> Lit -> m q
forall a b. (a -> b) -> a -> b
$ Char -> Lit
CharL Char
c
        where
          constr :: Constr
          constr :: Constr
constr = a -> Constr
forall a. Data a => a -> Constr
toConstr a
t

      Just m q
y -> m q
y


{- Note [Data for non-algebraic types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Class Data was originally intended for algebraic data types.  But
it is possible to use it for abstract types too.  For example, in
package `text` we find

  instance Data Text where
    ...
    toConstr _ = packConstr

  packConstr :: Constr
  packConstr = mkConstr textDataType "pack" [] Prefix

Here `packConstr` isn't a real data constructor, it's an ordinary
function.  Two complications

* In such a case, we must take care to build the Name using
  mkNameG_v (for values), not mkNameG_d (for data constructors).
  See #10796.

* The pseudo-constructor is named only by its string, here "pack".
  But 'dataToQa' needs the TyCon of its defining module, and has
  to assume it's defined in the same module as the TyCon itself.
  But nothing enforces that; #12596 shows what goes wrong if
  "pack" is defined in a different module than the data type "Text".
  -}

-- | 'dataToExpQ' converts a value to a 'Exp' representation of the
-- same value, in the SYB style. It is generalized to take a function
-- override type-specific cases; see 'liftData' for a more commonly
-- used variant.
dataToExpQ  ::  (Quote m, Data a)
            =>  (forall b . Data b => b -> Maybe (m Exp))
            ->  a
            ->  m Exp
dataToExpQ :: forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ = (Name -> m Exp)
-> (Lit -> m Exp)
-> (m Exp -> [m Exp] -> m Exp)
-> (forall b. Data b => b -> Maybe (m Exp))
-> a
-> m Exp
forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> m Exp
forall {m :: * -> *}. Monad m => Name -> m Exp
varOrConE Lit -> m Exp
forall {m :: * -> *}. Monad m => Lit -> m Exp
litE ((m Exp -> m Exp -> m Exp) -> m Exp -> [m Exp] -> m Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Exp -> m Exp -> m Exp
forall {m :: * -> *}. Monad m => m Exp -> m Exp -> m Exp
appE)
    where
          -- Make sure that VarE is used if the Constr value relies on a
          -- function underneath the surface (instead of a constructor).
          -- See #10796.
          varOrConE :: Name -> m Exp
varOrConE Name
s =
            case Name -> Maybe NameSpace
nameSpace Name
s of
                 Just NameSpace
VarName      -> Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
s)
                 Just (FldName {}) -> Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
s)
                 Just NameSpace
DataName     -> Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
ConE Name
s)
                 Maybe NameSpace
_ -> [Char] -> m Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> m Exp) -> [Char] -> m Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Can't construct an expression from name "
                           [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
showName Name
s
          appE :: m Exp -> m Exp -> m Exp
appE m Exp
x m Exp
y = do { a <- m Exp
x; b <- y; return (AppE a b)}
          litE :: Lit -> m Exp
litE Lit
c = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Exp
LitE Lit
c)

-- | 'liftData' is a variant of 'lift' in the 'Lift' type class which
-- works for any type with a 'Data' instance.
liftData :: (Quote m, Data a) => a -> m Exp
liftData :: forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData = (forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ (Maybe (m Exp) -> b -> Maybe (m Exp)
forall a b. a -> b -> a
const Maybe (m Exp)
forall a. Maybe a
Nothing)

-- | 'dataToPatQ' converts a value to a 'Pat' representation of the same
-- value, in the SYB style. It takes a function to handle type-specific cases,
-- alternatively, pass @const Nothing@ to get default behavior.
dataToPatQ  ::  (Quote m, Data a)
            =>  (forall b . Data b => b -> Maybe (m Pat))
            ->  a
            ->  m Pat
dataToPatQ :: forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Pat)) -> a -> m Pat
dataToPatQ = (Name -> Name)
-> (Lit -> m Pat)
-> (Name -> [m Pat] -> m Pat)
-> (forall b. Data b => b -> Maybe (m Pat))
-> a
-> m Pat
forall (m :: * -> *) a k q.
(Quote m, Data a) =>
(Name -> k)
-> (Lit -> m q)
-> (k -> [m q] -> m q)
-> (forall b. Data b => b -> Maybe (m q))
-> a
-> m q
dataToQa Name -> Name
forall a. a -> a
id Lit -> m Pat
forall {m :: * -> *}. Monad m => Lit -> m Pat
litP Name -> [m Pat] -> m Pat
forall {m :: * -> *}. Monad m => Name -> [m Pat] -> m Pat
conP
    where litP :: Lit -> m Pat
litP Lit
l = Pat -> m Pat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
LitP Lit
l)
          conP :: Name -> [m Pat] -> m Pat
conP Name
n [m Pat]
ps =
            case Name -> Maybe NameSpace
nameSpace Name
n of
                Just NameSpace
DataName -> do
                    ps' <- [m Pat] -> m [Pat]
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [m Pat]
ps
                    return (ConP n [] ps')
                Maybe NameSpace
_ -> [Char] -> m Pat
forall a. HasCallStack => [Char] -> a
error ([Char] -> m Pat) -> [Char] -> m Pat
forall a b. (a -> b) -> a -> b
$ [Char]
"Can't construct a pattern from name "
                          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
showName Name
n