{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}

module Language.Haskell.TH.Lift
  ( Lift(..)
  , Q
  , Code
  , Quote
  , Exp
  -- * Compatibilty shims
  , defaultLiftTyped
  , liftAddrCompat
  , liftIntCompat
  ) where

import GHC.Exts (Int(..))
import Data.Word (Word8)
#if  __GLASGOW_HASKELL__ < 810
import Foreign.Ptr (plusPtr)
import Foreign.Storable (peek)
import Foreign.ForeignPtr (withForeignPtr)
import System.IO.Unsafe (unsafePerformIO)
#endif
import Foreign.ForeignPtr (ForeignPtr)
#if __GLASGOW_HASKELL__ >= 912
import GHC.Internal.TH.Lift
import GHC.Internal.TH.Syntax
#else
import Language.Haskell.TH.Syntax
#endif
#if __GLASGOW_HASKELL__ >= 915
import GHC.Internal.TH.Monad
#endif


-- Quote and Code are introduced in GHC-9.0/template-haskell-2.17
-- If we are using an older version, it is basically synonymous with 'Q'
#if __GLASGOW_HASKELL__ < 900
type Quote m = (Q ~ m)
type Code m a = m (TExp a)
#endif

-- | Convert an implementation of 'lift' into one for 'liftTyped'.
#if  __GLASGOW_HASKELL__ >= 900
defaultLiftTyped :: (Lift a, Quote m) => a -> Code m a
defaultLiftTyped :: forall a (m :: * -> *). (Lift a, Quote m) => a -> Code m a
defaultLiftTyped 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)
-- template-haskell >= 2.17
#else
defaultLiftTyped :: (Lift a, Quote m) => a -> Q (TExp a)
defaultLiftTyped x = unsafeTExpCoerce (lift x)
-- template-haskell >= 2.16
#endif

-- | A compatibility shim for lifting an 'Addr#' value.
liftAddrCompat :: Quote m => ForeignPtr Word8 -> Word -> Word -> m Exp
liftAddrCompat :: forall (m :: * -> *).
Quote m =>
ForeignPtr Word8 -> Word -> Word -> m Exp
liftAddrCompat ForeignPtr Word8
fptr Word
off Word
len =
#if  __GLASGOW_HASKELL__ >= 810
     Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Bytes -> Lit
BytesPrimL (Bytes -> Lit) -> Bytes -> Lit
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Word -> Word -> Bytes
Bytes ForeignPtr Word8
fptr Word
off Word
len
#else
     do
       let
         loop !ptr 0 xs = pure $ reverse xs
         loop !ptr !len xs = do
           x <- peek ptr
           loop (ptr `plusPtr` 1) (len -1) (x:xs)
       let words = unsafePerformIO $ withForeignPtr fptr $ \ptr -> loop (ptr `plusPtr` (fromIntegral off)) len []
       pure $ LitE $ StringPrimL $ words
#endif

-- | A compatibility shim for lifting an 'Int' value without triggering bugs if @RebindableSyntax@ is used in a module.
liftIntCompat :: Quote m => Integer -> m Exp
liftIntCompat :: forall (m :: * -> *). Quote m => Integer -> m Exp
liftIntCompat Integer
n = Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'I#) (Lit -> Exp
LitE (Integer -> Lit
IntPrimL Integer
n))