{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif

#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE RoleAnnotations #-}
#endif

-- | This module exists to make it possible to define code that works across
-- a wide range of @template-haskell@ versions with as little CPP as possible.
-- To that end, this module currently backports the following
-- @template-haskell@ constructs:
--
-- * The 'Quote' class
--
-- * The 'Code' type
--
-- * The 'getPackageRoot' and 'makeRelativeToProject' utility functions
--
-- Refer to the Haddocks below for examples of how to use each of these in a
-- backwards-compatible way.
module Language.Haskell.TH.Syntax.Compat (
    -- * The @Quote@ class
    -- $quote
    Quote(..)
    -- * @Quote@ functionality
    -- ** The @unsafeQToQuote@ function
  , unsafeQToQuote
    -- ** Functions from @Language.Haskell.TH.Syntax@
#if MIN_VERSION_template_haskell(2,9,0)
  , unTypeQQuote
  , unsafeTExpCoerceQuote
#endif
  , liftQuote
#if MIN_VERSION_template_haskell(2,9,0)
  , liftTypedQuote
#endif
  , liftStringQuote

#if MIN_VERSION_template_haskell(2,9,0)
    -- * The @Code@ and @CodeQ@ types
    -- $code
  , Code(..), CodeQ
    -- * @Code@ functionality
    -- ** The @IsCode@ class
  , IsCode(..)
    -- ** Limitations of @IsCode@
    -- $isCodeLimitations
    -- ** Functions from @Language.Haskell.TH.Syntax@
  , unsafeCodeCoerce
  , liftCode
  , unTypeCode
  , hoistCode
  , bindCode
  , bindCode_
  , joinCode

  -- * Compatibility with @Splice@s
  -- $splice
  , Splice
  , SpliceQ
  , bindSplice
  , bindSplice_
  , examineSplice
  , hoistSplice
  , joinSplice
  , liftSplice
  , liftTypedFromUntypedSplice
  , unsafeSpliceCoerce
  , unTypeSplice
  , expToSplice
#endif

  -- * Package root functions
  , getPackageRoot
  , makeRelativeToProject
  ) where

import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO(..))
import Language.Haskell.TH (Exp)
import qualified Language.Haskell.TH.Lib as Lib ()
import Language.Haskell.TH.Syntax (Q, runQ, Quasi(..))
import qualified Language.Haskell.TH.Syntax as Syntax

#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative
#endif

#if MIN_VERSION_template_haskell(2,16,0)
import GHC.Exts (RuntimeRep, TYPE)
#endif

#if MIN_VERSION_template_haskell(2,17,0)
import Language.Haskell.TH.Lib (CodeQ)
import Language.Haskell.TH.Syntax
  ( Code(..), Quote(..)
  , bindCode, bindCode_, hoistCode, joinCode, liftCode, unsafeCodeCoerce, unTypeCode
  , unsafeTExpCoerce, unTypeQ )
#else
import Language.Haskell.TH (Name)
#endif

#if MIN_VERSION_template_haskell(2,19,0)
import Language.Haskell.TH.Syntax (getPackageRoot, makeRelativeToProject)
#else
import System.FilePath (isRelative, takeExtension, takeDirectory, (</>))
import System.Directory (getDirectoryContents, canonicalizePath)
#endif

-------------------------------------------------------------------------------
-- Quote
-------------------------------------------------------------------------------

-- $quote
-- The 'Quote' class (first proposed in
-- <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst GHC Proposal 246>)
-- was introduced in @template-haskell-2.17.0.0@. This module defines a version
-- of 'Quote' that is backward-compatible with older @template-haskell@
-- releases and is forward-compatible with the existing 'Quote' class.
--
-- In addition to 'Quote', this module also backports versions of functions in
-- "Language.Haskell.TH.Syntax" that work over any 'Quote' instance instead of
-- just 'Q'. Since this module is designed to coexist with the existing
-- definitions in @template-haskell@ as much as possible, the backported
-- functions are suffixed with @-Quote@ to avoid name clashes. For instance,
-- the backported version of 'lift' is named 'liftQuote'.
--
-- The one exception to the no-name-clashes policy is the backported 'newName'
-- method of 'Quote'. We could have conceivably named it 'newNameQuote', but
-- then it would not have been possible to define backwards-compatible 'Quote'
-- instances without the use of CPP. As a result, some care must be exercised
-- when combining this module with "Language.Haskell.TH" or
-- "Language.Haskell.TH.Syntax" on older versions of @template-haskell@, as
-- they both export a version of 'newName' with a different type. Here is an
-- example of how to safely combine these modules:
--
-- @
-- &#123;-&#35; LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell &#35;-&#125;
--
-- import Control.Monad.State (MonadState(..), State, evalState)
-- import "Language.Haskell.TH" hiding ('newName')
-- import "Language.Haskell.TH.Syntax" hiding ('newName')
-- import "Language.Haskell.TH.Syntax.Compat"
--
-- newtype PureQ a = MkPureQ (State Uniq a)
--   deriving (Functor, Applicative, Monad, MonadState Uniq)
--
-- runPureQ :: PureQ a -> a
-- runPureQ m = case m of MkPureQ m' -> evalState m' 0
--
-- instance 'Quote' PureQ where
--   'newName' s = state $ \i -> (mkNameU s i, i + 1)
--
-- main :: IO ()
-- main = putStrLn $ runPureQ $ do
--   a <- newName "a"
--   return $ nameBase a
-- @
--
-- We do not make an effort to backport any combinators from the
-- "Language.Haskell.TH.Lib" module, as the surface area is simply too large.
-- If you wish to generalize code that uses these combinators to work over
-- 'Quote' in a backwards-compatible way, use the 'unsafeQToQuote' function.

#if !(MIN_VERSION_template_haskell(2,17,0))
-- | The 'Quote' class implements the minimal interface which is necessary for
-- desugaring quotations.
--
-- * The @Monad m@ superclass is needed to stitch together the different
-- AST fragments.
-- * 'newName' is used when desugaring binding structures such as lambdas
-- to generate fresh names.
--
-- Therefore the type of an untyped quotation in GHC is `Quote m => m Exp`
--
-- For many years the type of a quotation was fixed to be `Q Exp` but by
-- more precisely specifying the minimal interface it enables the `Exp` to
-- be extracted purely from the quotation without interacting with `Q`.
class ( Monad m
# if   !(MIN_VERSION_template_haskell(2,7,0))
      , Functor m
# elif !(MIN_VERSION_template_haskell(2,10,0))
      , Applicative m
# endif
      ) => Quote m where
  {- |
  Generate a fresh name, which cannot be captured.

  For example, this:

  @f = $(do
    nm1 <- newName \"x\"
    let nm2 = 'mkName' \"x\"
    return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))
   )@

  will produce the splice

  >f = \x0 -> \x -> x0

  In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,
  and is not captured by the binding @VarP nm2@.

  Although names generated by @newName@ cannot /be captured/, they can
  /capture/ other names. For example, this:

  >g = $(do
  >  nm1 <- newName "x"
  >  let nm2 = mkName "x"
  >  return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))
  > )

  will produce the splice

  >g = \x -> \x0 -> x0

  since the occurrence @VarE nm2@ is captured by the innermost binding
  of @x@, namely @VarP nm1@.
  -}
  newName :: String -> m Name

instance Quote Q where
  newName :: String -> Q Name
newName = String -> Q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName
#endif

#if MIN_VERSION_template_haskell(2,9,0)
-- | Discard the type annotation and produce a plain Template Haskell
-- expression
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
--
-- This is a variant of the 'unTypeQ' function that is always guaranteed to
-- use a 'Quote' constraint, even on old versions of @template-haskell@.
--
-- As this function interacts with typed Template Haskell, this function is
-- only defined on @template-haskell-2.9.0.0@ (GHC 7.8) or later.
unTypeQQuote ::
# if MIN_VERSION_template_haskell(2,16,0)
  forall (r :: RuntimeRep) (a :: TYPE r) m .
# else
  forall a m .
# endif
  Quote m => m (Syntax.TExp a) -> m Exp
# if MIN_VERSION_template_haskell(2,17,0)
unTypeQQuote = unTypeQ
# else
unTypeQQuote :: m (TExp a) -> m Exp
unTypeQQuote m (TExp a)
m = do { Syntax.TExp Exp
e <- m (TExp a)
m
                    ; Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e }
# endif

-- | Annotate the Template Haskell expression with a type
--
-- This is unsafe because GHC cannot check for you that the expression
-- really does have the type you claim it has.
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
--
-- This is a variant of the 'unsafeTExpCoerce' function that is always
-- guaranteed to use a 'Quote' constraint, even on old versions of
-- @template-haskell@.
--
-- As this function interacts with typed Template Haskell, this function is
-- only defined on @template-haskell-2.9.0.0@ (GHC 7.8) or later.
unsafeTExpCoerceQuote ::
# if MIN_VERSION_template_haskell(2,16,0)
  forall (r :: RuntimeRep) (a :: TYPE r) m .
# else
  forall a m .
# endif
  Quote m => m Exp -> m (Syntax.TExp a)
# if MIN_VERSION_template_haskell(2,17,0)
unsafeTExpCoerceQuote = unsafeTExpCoerce
# else
unsafeTExpCoerceQuote :: m Exp -> m (TExp a)
unsafeTExpCoerceQuote m Exp
m = do { Exp
e <- m Exp
m
                             ; TExp a -> m (TExp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> TExp a
forall a. Exp -> TExp a
Syntax.TExp Exp
e) }
# endif
#endif

-- | Turn a value into a Template Haskell expression, suitable for use in
-- a splice.
--
-- This is a variant of the 'Syntax.lift' method of 'Syntax.Lift' that is
-- always guaranteed to use a 'Quote' constraint, even on old versions of
-- @template-haskell@.
--
-- Levity-polymorphic since /template-haskell-2.17.0.0/.
liftQuote ::
#if MIN_VERSION_template_haskell(2,17,0)
  forall (r :: RuntimeRep) (t :: TYPE r) m .
#else
  forall t m .
#endif
  (Syntax.Lift t, Quote m) => t -> m Exp
#if MIN_VERSION_template_haskell(2,17,0)
liftQuote = Syntax.lift
#else
liftQuote :: t -> m Exp
liftQuote = Q Exp -> m Exp
forall (m :: * -> *) a. Quote m => Q a -> m a
unsafeQToQuote (Q Exp -> m Exp) -> (t -> Q Exp) -> t -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Q Exp
forall t. Lift t => t -> Q Exp
Syntax.lift
#endif

#if MIN_VERSION_template_haskell(2,9,0)
-- | Turn a value into a Template Haskell typed expression, suitable for use
-- in a typed splice.
--
-- This is a variant of the 'Syntax.liftTyped' method of 'Syntax.Lift' that is
-- always guaranteed to use a 'Quote' constraint and return a 'Code', even on
-- old versions of @template-haskell@.
--
-- As this function interacts with typed Template Haskell, this function is
-- only defined on @template-haskell-2.9.0.0@ (GHC 7.8) or later. While the
-- 'Syntax.liftTyped' method of 'Syntax.Lift' was first introduced in
-- @template-haskell-2.16.0.0@, we are able to backport it back to
-- @template-haskell-2.9.0.0@ by making use of the 'Syntax.lift' method on
-- older versions of @template-haskell@. This crucially relies on the
-- 'Syntax.Lift' law that @'lift' x ≡ 'unTypeQ' ('liftTyped' x)@ to work,
-- so beware if you use 'liftTypedQuote' with an unlawful 'Syntax.Lift'
-- instance.
--
-- Levity-polymorphic since /template-haskell-2.17.0.0/.
liftTypedQuote ::
# if MIN_VERSION_template_haskell(2,17,0)
  forall (r :: RuntimeRep) (t :: TYPE r) m .
# else
  forall t m .
# endif
  (Syntax.Lift t, Quote m) => t -> Code m t
# if MIN_VERSION_template_haskell(2,17,0)
liftTypedQuote = Syntax.liftTyped
# elif MIN_VERSION_template_haskell(2,16,0)
liftTypedQuote :: t -> Code m t
liftTypedQuote = m (TExp t) -> Code m t
forall a (m :: * -> *). m (TExp a) -> Code m a
liftCode (m (TExp t) -> Code m t) -> (t -> m (TExp t)) -> t -> Code m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q (TExp t) -> m (TExp t)
forall (m :: * -> *) a. Quote m => Q a -> m a
unsafeQToQuote (Q (TExp t) -> m (TExp t)) -> (t -> Q (TExp t)) -> t -> m (TExp t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Q (TExp t)
forall t. Lift t => t -> Q (TExp t)
Syntax.liftTyped
# else
liftTypedQuote = unsafeCodeCoerce . liftQuote
# endif
#endif

-- | This is a variant of the 'Syntax.liftString' function that is always
-- guaranteed to use a 'Quote' constraint, even on old versions of
-- @template-haskell@.
liftStringQuote :: Quote m => String -> m Exp
#if MIN_VERSION_template_haskell(2,17,0)
liftStringQuote = Syntax.liftString
#else
liftStringQuote :: String -> m Exp
liftStringQuote = Q Exp -> m Exp
forall (m :: * -> *) a. Quote m => Q a -> m a
unsafeQToQuote (Q Exp -> m Exp) -> (String -> Q Exp) -> String -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
Syntax.liftString
#endif

-- | Use a 'Q' computation in a 'Quote' context. This function is only safe
-- when the 'Q' computation performs actions from the 'Quote' instance for 'Q'
-- or any of `Quote`'s subclasses ('Functor', 'Applicative', and 'Monad').
-- Attempting to perform actions from the 'MonadFail', 'MonadIO', or 'Quasi'
-- instances for 'Q' will result in runtime errors.
--
-- This is useful when you have some 'Q'-valued functions that only performs
-- actions from 'Quote' and wish to generalise it from 'Q' to 'Quote' without
-- having to rewrite the internals of the function. This is especially handy
-- for code defined in terms of combinators from "Language.Haskell.TH.Lib",
-- which were all hard-coded to 'Q' prior to @template-haskell-2.17.0.0@. For
-- instance, consider this function:
--
-- @
-- apply :: 'Exp' -> 'Exp' -> 'Q' 'Exp'
-- apply f x = 'Lib.appE' (return x) (return y)
-- @
--
-- There are two ways to generalize this function to use 'Quote' in a
-- backwards-compatible way. One way to do so is to rewrite @apply@ to avoid
-- the use of 'Lib.appE', like so:
--
-- @
-- applyQuote :: 'Quote' m => 'Exp' -> 'Exp' -> m 'Exp'
-- applyQuote f x = return ('Syntax.AppE' x y)
-- @
--
-- For a small example like @applyQuote@, there isn't much work involved. But
-- this can become tiresome for larger examples. In such cases,
-- 'unsafeQToQuote' can do the heavy lifting for you. For example, @applyQuote@
-- can also be defined as:
--
-- @
-- applyQuote :: 'Quote' m => 'Exp' -> 'Exp' -> m 'Exp'
-- applyQuote f x = 'unsafeQToQuote' (apply f x)
-- @
unsafeQToQuote :: Quote m => Q a -> m a
unsafeQToQuote :: Q a -> m a
unsafeQToQuote = QuoteToQuasi m a -> m a
forall (m :: * -> *) a. QuoteToQuasi m a -> m a
unQTQ (QuoteToQuasi m a -> m a)
-> (Q a -> QuoteToQuasi m a) -> Q a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q a -> QuoteToQuasi m a
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ

-- | An internal definition that powers 'unsafeQToQuote'. Its 'Quasi' instance
-- defines 'qNewName' in terms of 'newName' from 'Quote', but defines every
-- other method of 'Quasi' to be an error, since they cannot be implemented
-- using 'Quote' alone. Similarly, its 'MonadFail' and 'MonadIO' instances
-- define 'fail' and 'liftIO', respectively, to be errors.
newtype QuoteToQuasi (m :: * -> *) a = QTQ { QuoteToQuasi m a -> m a
unQTQ :: m a }
  deriving (a -> QuoteToQuasi m b -> QuoteToQuasi m a
(a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b
(forall a b. (a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b)
-> (forall a b. a -> QuoteToQuasi m b -> QuoteToQuasi m a)
-> Functor (QuoteToQuasi m)
forall a b. a -> QuoteToQuasi m b -> QuoteToQuasi m a
forall a b. (a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b
forall (m :: * -> *) a b.
Functor m =>
a -> QuoteToQuasi m b -> QuoteToQuasi m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> QuoteToQuasi m b -> QuoteToQuasi m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> QuoteToQuasi m b -> QuoteToQuasi m a
fmap :: (a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b
Functor, Functor (QuoteToQuasi m)
a -> QuoteToQuasi m a
Functor (QuoteToQuasi m)
-> (forall a. a -> QuoteToQuasi m a)
-> (forall a b.
    QuoteToQuasi m (a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b)
-> (forall a b c.
    (a -> b -> c)
    -> QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m c)
-> (forall a b.
    QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b)
-> (forall a b.
    QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m a)
-> Applicative (QuoteToQuasi m)
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m a
QuoteToQuasi m (a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b
(a -> b -> c)
-> QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m c
forall a. a -> QuoteToQuasi m a
forall a b.
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m a
forall a b.
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b
forall a b.
QuoteToQuasi m (a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b
forall a b c.
(a -> b -> c)
-> QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (QuoteToQuasi m)
forall (m :: * -> *) a. Applicative m => a -> QuoteToQuasi m a
forall (m :: * -> *) a b.
Applicative m =>
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m a
forall (m :: * -> *) a b.
Applicative m =>
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b
forall (m :: * -> *) a b.
Applicative m =>
QuoteToQuasi m (a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m c
<* :: QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m a
*> :: QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b
liftA2 :: (a -> b -> c)
-> QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m c
<*> :: QuoteToQuasi m (a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
QuoteToQuasi m (a -> b) -> QuoteToQuasi m a -> QuoteToQuasi m b
pure :: a -> QuoteToQuasi m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> QuoteToQuasi m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (QuoteToQuasi m)
Applicative, Applicative (QuoteToQuasi m)
a -> QuoteToQuasi m a
Applicative (QuoteToQuasi m)
-> (forall a b.
    QuoteToQuasi m a -> (a -> QuoteToQuasi m b) -> QuoteToQuasi m b)
-> (forall a b.
    QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b)
-> (forall a. a -> QuoteToQuasi m a)
-> Monad (QuoteToQuasi m)
QuoteToQuasi m a -> (a -> QuoteToQuasi m b) -> QuoteToQuasi m b
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b
forall a. a -> QuoteToQuasi m a
forall a b.
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b
forall a b.
QuoteToQuasi m a -> (a -> QuoteToQuasi m b) -> QuoteToQuasi m b
forall (m :: * -> *). Monad m => Applicative (QuoteToQuasi m)
forall (m :: * -> *) a. Monad m => a -> QuoteToQuasi m a
forall (m :: * -> *) a b.
Monad m =>
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b
forall (m :: * -> *) a b.
Monad m =>
QuoteToQuasi m a -> (a -> QuoteToQuasi m b) -> QuoteToQuasi m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> QuoteToQuasi m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> QuoteToQuasi m a
>> :: QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
QuoteToQuasi m a -> QuoteToQuasi m b -> QuoteToQuasi m b
>>= :: QuoteToQuasi m a -> (a -> QuoteToQuasi m b) -> QuoteToQuasi m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
QuoteToQuasi m a -> (a -> QuoteToQuasi m b) -> QuoteToQuasi m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (QuoteToQuasi m)
Monad)

qtqError :: String -> a
qtqError :: String -> a
qtqError String
name = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"`unsafeQToQuote` does not support code that uses " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name

instance Monad m => Fail.MonadFail (QuoteToQuasi m) where
  fail :: String -> QuoteToQuasi m a
fail = String -> String -> QuoteToQuasi m a
forall a. String -> a
qtqError String
"MonadFail.fail"

instance Monad m => MonadIO (QuoteToQuasi m) where
  liftIO :: IO a -> QuoteToQuasi m a
liftIO = String -> IO a -> QuoteToQuasi m a
forall a. String -> a
qtqError String
"liftIO"

instance Quote m => Quasi (QuoteToQuasi m) where
  qNewName :: String -> QuoteToQuasi m Name
qNewName String
s = m Name -> QuoteToQuasi m Name
forall (m :: * -> *) a. m a -> QuoteToQuasi m a
QTQ (String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
s)

  qRecover :: QuoteToQuasi m a -> QuoteToQuasi m a -> QuoteToQuasi m a
qRecover            = String -> QuoteToQuasi m a -> QuoteToQuasi m a -> QuoteToQuasi m a
forall a. String -> a
qtqError String
"qRecover"
  qReport :: Bool -> String -> QuoteToQuasi m ()
qReport             = String -> Bool -> String -> QuoteToQuasi m ()
forall a. String -> a
qtqError String
"qReport"
  qReify :: Name -> QuoteToQuasi m Info
qReify              = String -> Name -> QuoteToQuasi m Info
forall a. String -> a
qtqError String
"qReify"
  qLocation :: QuoteToQuasi m Loc
qLocation           = String -> QuoteToQuasi m Loc
forall a. String -> a
qtqError String
"qLocation"
  qRunIO :: IO a -> QuoteToQuasi m a
qRunIO              = String -> IO a -> QuoteToQuasi m a
forall a. String -> a
qtqError String
"qRunIO"
#if MIN_VERSION_template_haskell(2,7,0)
  qReifyInstances :: Name -> [Type] -> QuoteToQuasi m [Dec]
qReifyInstances     = String -> Name -> [Type] -> QuoteToQuasi m [Dec]
forall a. String -> a
qtqError String
"qReifyInstances"
  qLookupName :: Bool -> String -> QuoteToQuasi m (Maybe Name)
qLookupName         = String -> Bool -> String -> QuoteToQuasi m (Maybe Name)
forall a. String -> a
qtqError String
"qLookupName"
  qAddDependentFile :: String -> QuoteToQuasi m ()
qAddDependentFile   = String -> String -> QuoteToQuasi m ()
forall a. String -> a
qtqError String
"qAddDependentFile"
# if MIN_VERSION_template_haskell(2,9,0)
  qReifyRoles :: Name -> QuoteToQuasi m [Role]
qReifyRoles         = String -> Name -> QuoteToQuasi m [Role]
forall a. String -> a
qtqError String
"qReifyRoles"
  qReifyAnnotations :: AnnLookup -> QuoteToQuasi m [a]
qReifyAnnotations   = String -> AnnLookup -> QuoteToQuasi m [a]
forall a. String -> a
qtqError String
"qReifyAnnotations"
  qReifyModule :: Module -> QuoteToQuasi m ModuleInfo
qReifyModule        = String -> Module -> QuoteToQuasi m ModuleInfo
forall a. String -> a
qtqError String
"qReifyModule"
  qAddTopDecls :: [Dec] -> QuoteToQuasi m ()
qAddTopDecls        = String -> [Dec] -> QuoteToQuasi m ()
forall a. String -> a
qtqError String
"qAddTopDecls"
  qAddModFinalizer :: Q () -> QuoteToQuasi m ()
qAddModFinalizer    = String -> Q () -> QuoteToQuasi m ()
forall a. String -> a
qtqError String
"qAddModFinalizer"
  qGetQ :: QuoteToQuasi m (Maybe a)
qGetQ               = String -> QuoteToQuasi m (Maybe a)
forall a. String -> a
qtqError String
"qGetQ"
  qPutQ :: a -> QuoteToQuasi m ()
qPutQ               = String -> a -> QuoteToQuasi m ()
forall a. String -> a
qtqError String
"qPutQ"
# endif
# if MIN_VERSION_template_haskell(2,11,0)
  qReifyFixity :: Name -> QuoteToQuasi m (Maybe Fixity)
qReifyFixity        = String -> Name -> QuoteToQuasi m (Maybe Fixity)
forall a. String -> a
qtqError String
"qReifyFixity"
  qReifyConStrictness :: Name -> QuoteToQuasi m [DecidedStrictness]
qReifyConStrictness = String -> Name -> QuoteToQuasi m [DecidedStrictness]
forall a. String -> a
qtqError String
"qReifyConStrictness"
  qIsExtEnabled :: Extension -> QuoteToQuasi m Bool
qIsExtEnabled       = String -> Extension -> QuoteToQuasi m Bool
forall a. String -> a
qtqError String
"qIsExtEnabled"
  qExtsEnabled :: QuoteToQuasi m [Extension]
qExtsEnabled        = String -> QuoteToQuasi m [Extension]
forall a. String -> a
qtqError String
"qExtsEnabled"
# endif
#elif MIN_VERSION_template_haskell(2,5,0)
  qClassInstances     = qtqError "qClassInstances"
#endif
#if MIN_VERSION_template_haskell(2,13,0)
  qAddCorePlugin :: String -> QuoteToQuasi m ()
qAddCorePlugin      = String -> String -> QuoteToQuasi m ()
forall a. String -> a
qtqError String
"qAddCorePlugin"
#endif
#if MIN_VERSION_template_haskell(2,14,0)
  qAddForeignFilePath :: ForeignSrcLang -> String -> QuoteToQuasi m ()
qAddForeignFilePath = String -> ForeignSrcLang -> String -> QuoteToQuasi m ()
forall a. String -> a
qtqError String
"qAddForeignFilePath"
  qAddTempFile :: String -> QuoteToQuasi m String
qAddTempFile        = String -> String -> QuoteToQuasi m String
forall a. String -> a
qtqError String
"qAddTempFile"
#elif MIN_VERSION_template_haskell(2,12,0)
  qAddForeignFile     = qtqError "qAddForeignFile"
#endif
#if MIN_VERSION_template_haskell(2,16,0)
  qReifyType :: Name -> QuoteToQuasi m Type
qReifyType          = String -> Name -> QuoteToQuasi m Type
forall a. String -> a
qtqError String
"qReifyType"
#endif
#if MIN_VERSION_template_haskell(2,18,0)
  qGetDoc             = qtqError "qGetDoc"
  qPutDoc             = qtqError "qPutDoc"
#endif
#if MIN_VERSION_template_haskell(2,19,0)
  qGetPackageRoot     = qtqError "qGetPackageRoot"
#endif

-------------------------------------------------------------------------------
-- Code
-------------------------------------------------------------------------------

-- $code
-- The 'Code' type (first proposed in
-- <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0195-code-texp.rst GHC Proposal 195>)
-- was introduced in @template-haskell-2.17.0.0@. This module defines a version
-- of 'Code' that is backward-compatible with older @template-haskell@
-- releases and is forward-compatible with the existing 'Code' class.
-- In addition to 'Code', this module also backports the functions in
-- "Language.Haskell.TH.Syntax" that manipulate 'Code' values.
--
-- One troublesome aspect of writing backwards-compatible code involving 'Code'
-- is that GHC 9.0 changed the types of typed Template Haskell splices. Before,
-- they were of type @'Q' ('TExp' a)@, but they are now of type @'Code' 'Q' a@.
-- This modules provides two mechanisms for smoothing over the differences
-- between these two types:
--
-- * The 'IsCode' class can be used to convert 'Code' or 'TExp' values to
--   'Code', and vice versa.
--
-- * The 'Splice' type synonym uses CPP so that @'Splice' q a@ is a synonym for
--   @'Code' q a@ on GHC 9.0 or later and @q ('TExp' a)@ on older versions of
--   GHC. This module also defines versions of 'Code'- and 'TExp'-related
--   combinators that work over 'Splice'.
--
-- Refer to the Haddocks for 'IsCode' and 'Splice' for more information on each
-- approach. Both approaches have pros and cons, and as a result, neither
-- approach is a one-size-fits-all solution.
--
-- Because 'Code' interacts with typed Template Haskell, the 'Code' type and
-- any function that mentions 'Code' in its type are only defined on
-- @template-haskell-2.9.0.0@ (GHC 7.8) or later.

#if MIN_VERSION_template_haskell(2,9,0)
-- | A class that allows one to smooth over the differences between
-- @'Code' 'm' a@ (the type of typed Template Haskell quotations on
-- @template-haskell-2.17.0.0@ or later) and @'m' ('TExp' a)@ (the type of
-- typed Template Haskell quotations on older versions of @template-haskell@).
-- Here are two examples that demonstrate how to use each method of 'IsCode':
--
-- @
-- &#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
--
-- import "Language.Haskell.TH"
-- import "Language.Haskell.TH.Syntax.Compat"
--
-- -- 'toCode' will ensure that the end result is a 'Code', regardless of
-- -- whether the quote itself returns a 'Code' or a 'TExp'.
-- myCode :: 'Code' 'Q' Int
-- myCode = 'toCode' [|| 42 ||]
--
-- -- 'fromCode' will ensure that the input 'Code' is suitable for splicing
-- -- (i.e., it will return a 'Code' or a 'TExp' depending on the
-- -- @template-haskell@ version in use).
-- fortyTwo :: Int
-- fortyTwo = $$('fromCode' myCode)
-- @
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
class IsCode q
# if MIN_VERSION_template_haskell(2,16,0)
             (a :: TYPE r)
# else
             a
# endif
             c | c -> a q where
  -- | Convert something to a 'Code'.
  toCode   :: c -> Code q a
  -- | Convert to something from a 'Code'.
  fromCode :: Code q a -> c

-- | Levity-polymorphic since /template-haskell-2.16.0.0/.
instance Quote q => IsCode q
# if MIN_VERSION_template_haskell(2,16,0)
                           (a :: TYPE r)
# else
                           a
# endif
                           (Code q a) where
  toCode :: Code q a -> Code q a
toCode   = Code q a -> Code q a
forall a. a -> a
id
  fromCode :: Code q a -> Code q a
fromCode = Code q a -> Code q a
forall a. a -> a
id

-- | Levity-polymorphic since /template-haskell-2.16.0.0/.
instance texp ~ Syntax.TExp a => IsCode Q
# if MIN_VERSION_template_haskell(2,16,0)
                                        (a :: TYPE r)
# else
                                        a
# endif
                                        (Q texp) where
  toCode :: Q texp -> Code Q a
toCode   = Q texp -> Code Q a
forall a (m :: * -> *). m (TExp a) -> Code m a
liftCode
  fromCode :: Code Q a -> Q texp
fromCode = Code Q a -> Q texp
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode

-- $isCodeLimitations
-- 'IsCode' makes it possible to backport code involving typed Template Haskell
-- quotations and splices where the types are monomorphized to 'Q'. GHC 9.0
-- and later, however, make it possible to use typed TH quotations and splices
-- that are polymorphic over any 'Quote' instance. Unfortunately, the
-- @th-compat@ library does not yet have a good story for backporting
-- 'Quote'-polymorphic quotations or splices. For example, consider this code:
--
-- @
-- instance ('Syntax.Lift' a, 'Quote' q, 'Num' a) => 'Num' ('Code' q a) where
--   -- ...
--   x + y = [|| $$x + $$y ||]
--   -- ...
-- @
--
-- How might we backport this code? If we were in a setting where @q@ were
-- monomorphized to 'Q', we could simply write this:
--
-- @
--   x + y = 'toCode' [|| $$('fromCode' x) + $$('fromCode' y) ||]
-- @
--
-- In a 'Quote'-polymorphic setting, however, we run into issues. While this
-- will compile on GHC 9.0 or later, it will not compile on earlier GHC
-- versions because all typed TH quotations and splices must use 'Q'. At
-- present, the @th-compat@ library does not offer any solution to this
-- problem.

-- | Levity-polymorphic since /template-haskell-2.16.0.0/.
# if !(MIN_VERSION_template_haskell(2,17,0))
type role Code representational nominal
newtype Code m
#  if MIN_VERSION_template_haskell(2,16,0)
             (a :: TYPE (r :: RuntimeRep))
#  else
             a
#  endif
  = Code
  { Code m a -> m (TExp a)
examineCode :: m (Syntax.TExp a) -- ^ Underlying monadic value
  }

type CodeQ = Code Q
# if MIN_VERSION_template_haskell(2,16,0)
                    :: (TYPE r -> *)
# endif

-- | Unsafely convert an untyped code representation into a typed code
-- representation.
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
unsafeCodeCoerce ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall (r :: RuntimeRep) (a :: TYPE r) m .
#  else
  forall a m .
#  endif
  Quote m => m Exp -> Code m a
unsafeCodeCoerce :: m Exp -> Code m a
unsafeCodeCoerce m Exp
m = m (TExp a) -> Code m a
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code (m Exp -> m (TExp a)
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
unsafeTExpCoerceQuote m Exp
m)

-- | Lift a monadic action producing code into the typed 'Code'
-- representation
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
liftCode ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall (r :: RuntimeRep) (a :: TYPE r) m .
#  else
  forall a m .
#  endif
  m (Syntax.TExp a) -> Code m a
liftCode :: m (TExp a) -> Code m a
liftCode = m (TExp a) -> Code m a
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code

-- | Extract the untyped representation from the typed representation
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
unTypeCode ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall (r :: RuntimeRep) (a :: TYPE r) m .
#  else
  forall a m .
#  endif
  Quote m => Code m a -> m Exp
unTypeCode :: Code m a -> m Exp
unTypeCode = m (TExp a) -> m Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
unTypeQQuote (m (TExp a) -> m Exp)
-> (Code m a -> m (TExp a)) -> Code m a -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code m a -> m (TExp a)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode

-- | Modify the ambient monad used during code generation. For example, you
-- can use `hoistCode` to handle a state effect:
--
-- @
--  handleState :: Code (StateT Int Q) a -> Code Q a
--  handleState = hoistCode (flip runState 0)
-- @
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
hoistCode ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall m n (r :: RuntimeRep) (a :: TYPE r) .
#  else
  forall m n a .
#  endif
  Monad m => (forall x . m x -> n x) -> Code m a -> Code n a
hoistCode :: (forall x. m x -> n x) -> Code m a -> Code n a
hoistCode forall x. m x -> n x
f (Code m (TExp a)
a) = n (TExp a) -> Code n a
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code (m (TExp a) -> n (TExp a)
forall x. m x -> n x
f m (TExp a)
a)


-- | Variant of (>>=) which allows effectful computations to be injected
-- into code generation.
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
bindCode ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall m a (r :: RuntimeRep) (b :: TYPE r) .
#  else
  forall m a b .
#  endif
  Monad m => m a -> (a -> Code m b) -> Code m b
bindCode :: m a -> (a -> Code m b) -> Code m b
bindCode m a
q a -> Code m b
k = m (TExp b) -> Code m b
forall a (m :: * -> *). m (TExp a) -> Code m a
liftCode (m a
q m a -> (a -> m (TExp b)) -> m (TExp b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Code m b -> m (TExp b)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode (Code m b -> m (TExp b)) -> (a -> Code m b) -> a -> m (TExp b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Code m b
k)

-- | Variant of (>>) which allows effectful computations to be injected
-- into code generation.
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
bindCode_ ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall m a (r :: RuntimeRep) (b :: TYPE r) .
#  else
  forall m a b .
#  endif
  Monad m => m a -> Code m b -> Code m b
bindCode_ :: m a -> Code m b -> Code m b
bindCode_ m a
q Code m b
c = m (TExp b) -> Code m b
forall a (m :: * -> *). m (TExp a) -> Code m a
liftCode ( m a
q m a -> m (TExp b) -> m (TExp b)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Code m b -> m (TExp b)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode Code m b
c)

-- | A useful combinator for embedding monadic actions into 'Code'
-- @
-- myCode :: ... => Code m a
-- myCode = joinCode $ do
--   x <- someSideEffect
--   return (makeCodeWith x)
-- @
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
joinCode ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall m (r :: RuntimeRep) (a :: TYPE r) .
#  else
  forall m a .
#  endif
  Monad m => m (Code m a) -> Code m a
joinCode :: m (Code m a) -> Code m a
joinCode = (m (Code m a) -> (Code m a -> Code m a) -> Code m a)
-> (Code m a -> Code m a) -> m (Code m a) -> Code m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (Code m a) -> (Code m a -> Code m a) -> Code m a
forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> Code m b) -> Code m b
bindCode Code m a -> Code m a
forall a. a -> a
id
# endif

-- $splice
--
-- This section of code is useful for library authors looking to provide
-- a typed @TemplateHaskell@ interface that is backwards- and
-- forward-compatible. This section may be useful for you if you
-- specifically intend for the splice to be done directly.
--
-- Prior to GHC 9, you'd offer a value with type @'Q' ('Syntax.TExp' a)@.
-- After GHC 9, these values are no longer acceptable in a typed splice:
-- typed splices must operate in @Code m a@ instead.
--
-- The @'Splice' m a@ type is used to work with both versions - it is a type
-- alias, and depending on the version of @template-haskell@ that was
-- compiled, it will either be @'Code' m a@ or @m ('Syntax.TExp' a)@.
--
-- The function 'liftSplice' can be used to convert a @'Q' ('Syntax.TExp' a)@
-- expression into a @'Code' 'Q' a@ expression in a compatible manner - by
-- lifting to 'SpliceQ', you get the right behavior depending on your
-- @template-haskell@ version.
--
-- The function 'examineSplice' can be used on typed QuasiQuoters, and the
-- result will be converted into an appropriate @m ('Syntax.TExp' a)@. This
-- allows you to use typed quasiquoters in a @do@ block, much like
-- 'examineCode' does with 'Code'.
--
-- With 'expToSplice', you can substitute uses of 'pure' when given the
-- specific type:
--
-- @
-- pureTExp :: 'Syntax.TExp' a -> 'Q' ('Syntax.TExp' a)
-- pureTExp = pure
-- @
--
-- This allows you to splice @'Syntax.TExp' a@ values directly into a typed
-- quasiquoter.

-- | @'Splice' m a@ is a type alias for:
--
-- * @'Code' m a@, if using @template-haskell-2.17.0.0@ or later, or
--
-- * @m ('Syntax.TExp' a)@, if using an older version of @template-haskell@.
--
-- This should be used with caution, as its definition differs depending on
-- which version of @template-haskell@ you are using. It is mostly useful for
-- contexts in which one is writing a definition that is intended to be used
-- directly in a typed Template Haskell splice, as the types of TH splices
-- differ between @template-haskell@ versions as well.
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
# if MIN_VERSION_template_haskell(2,17,0)
type Splice  = Code :: (forall r. (* -> *) -> TYPE r -> *)
# elif MIN_VERSION_template_haskell(2,16,0)
type Splice m (a :: TYPE r) = m (Syntax.TExp a)
# else
type Splice m a = m (Syntax.TExp a)
# endif

-- | @'SpliceQ' a@ is a type alias for:
--
-- * @'Code' 'Q' a@, if using @template-haskell-2.17.0.0@ or later, or
--
-- * @'Q' ('Syntax.TExp' a)@, if using an older version of @template-haskell@.
--
-- This should be used with caution, as its definition differs depending on
-- which version of @template-haskell@ you are using. It is mostly useful for
-- contexts in which one is writing a definition that is intended to be used
-- directly in a typed Template Haskell splice, as the types of TH splices
-- differ between @template-haskell@ versions as well.
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
# if MIN_VERSION_template_haskell(2,17,0)
type SpliceQ = Splice Q :: (TYPE r -> *)
# elif MIN_VERSION_template_haskell(2,16,0)
type SpliceQ (a :: TYPE r) = Splice Q a
# else
type SpliceQ a = Splice Q a
# endif

-- | A variant of 'bindCode' that works over 'Splice's. Because this function
-- uses 'Splice', the type of this function will be different depending on
-- which version of @template-haskell@ you are using. (See the Haddocks for
-- 'Splice' for more information on this point.)
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
bindSplice ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall m a (r :: RuntimeRep) (b :: TYPE r) .
#  else
  forall m a b .
#  endif
  Monad m => m a -> (a -> Splice m b) -> Splice m b
# if MIN_VERSION_template_haskell(2,17,0)
bindSplice = bindCode
# else
bindSplice :: m a -> (a -> Splice m b) -> Splice m b
bindSplice m a
q a -> Splice m b
k = Splice m b -> Splice m b
forall a (m :: * -> *). m (TExp a) -> m (TExp a)
liftSplice (m a
q m a -> (a -> Splice m b) -> Splice m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Splice m b -> Splice m b
forall (m :: * -> *) a. Splice m a -> Splice m a
examineSplice (Splice m b -> Splice m b) -> (a -> Splice m b) -> a -> Splice m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Splice m b
k)
# endif

-- | A variant of 'bindCode_' that works over 'Splice's. Because this function
-- uses 'Splice', the type of this function will be different depending on
-- which version of @template-haskell@ you are using. (See the Haddocks for
-- 'Splice' for more information on this point.)
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
bindSplice_ ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall m a (r :: RuntimeRep) (b :: TYPE r) .
#  else
  forall m a b .
#  endif
  Monad m => m a -> Splice m b -> Splice m b
# if MIN_VERSION_template_haskell(2,17,0)
bindSplice_ = bindCode_
# else
bindSplice_ :: m a -> Splice m b -> Splice m b
bindSplice_ m a
q Splice m b
c = Splice m b -> Splice m b
forall a (m :: * -> *). m (TExp a) -> m (TExp a)
liftSplice ( m a
q m a -> Splice m b -> Splice m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Splice m b -> Splice m b
forall (m :: * -> *) a. Splice m a -> Splice m a
examineSplice Splice m b
c)
# endif

-- | Lift a @'Syntax.TExp' a@ into a 'Splice'. This is useful when splicing
-- in the result of a computation into a typed QuasiQuoter.
--
-- One example is 'traverse'ing over a list of elements and returning an
-- expression from each element.
--
-- @
-- mkInt :: 'String' -> 'Q' ('Syntax.TExp' 'Int')
-- mkInt str = [|| length $$str ||]
--
-- mkInts :: ['String'] -> 'Q' ['Syntax.TExp' 'Int']
-- mkInts = traverse mkInt
-- @
--
-- This gives us a list of 'Syntax.TExp', not a 'Syntax.TExp' of a list. We
-- can push the list inside the type with this function:
--
-- @
-- listTE :: ['Syntax.TExp' a] -> 'Syntax.TExp' [a]
-- listTE = 'Syntax.TExp' . 'Syntax.ListE' . 'map' 'Syntax.unType'
-- @
--
-- In a @do@ block using 'liftSplice', we can bind the resulting
--
-- @'Syntax.TExp' ['Int']@ out of the expression.
--
-- @
-- foo :: 'Q' ('Syntax.TExp' Int)
-- foo = do
--      ints <- mkInts ["hello", "world", "goodybe", "bob"]
--      [|| sum $$(pure (listTE ints)) ||]
-- @
--
-- Prior to GHC 9, with the 'Q' type, we can write @'pure' :: 'Syntax.TExp' a -> 'Q' ('Syntax.TExp' a)@,
-- which is a valid thing to use in a typed quasiquoter.
-- However, after GHC 9, this code will fail to type check. There is no
-- 'Applicative' instance for @'Code' m a@, so we need another way to
-- splice it in.
--
-- A GHC 9 only solution can use @'Code' :: m ('Syntax.TExp' a) -> Code
-- m a@ and 'pure' together, like: @'Code' . 'pure'@.
--
-- With 'expToSplice', we can splice it in a backwards compatible way.
-- A fully backwards- and forwards-compatible example looks like this:
--
-- @
-- mkInt :: 'String' -> 'Q' 'Int'
-- mkInt str = 'examineSplice' [|| length $$str ||]
--
-- mkInts :: ['String'] -> 'Q' ['Syntax.TExp' 'Int']
-- mkInts = traverse mkInt
--
-- foo :: 'SpliceQ' 'Int'
-- foo = 'liftSplice' $ do
--      ints <- mkInts ["hello", "world", "goodybe", "bob"]
--      'examineSplice' [|| sum $$(expToSplice (listTE ints)) ||]
-- @
--
-- @since 0.1.3
expToSplice :: Applicative m => Syntax.TExp a -> Splice m a
expToSplice :: TExp a -> Splice m a
expToSplice TExp a
a = Splice m a -> Splice m a
forall a (m :: * -> *). m (TExp a) -> m (TExp a)
liftSplice (Splice m a -> Splice m a) -> Splice m a -> Splice m a
forall a b. (a -> b) -> a -> b
$ TExp a -> Splice m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TExp a
a

-- | A variant of 'examineCode' that takes a 'Splice' as an argument. Because
-- this function takes a 'Splice' as an argyment, the type of this function
-- will be different depending on which version of @template-haskell@ you are
-- using. (See the Haddocks for 'Splice' for more information on this point.)
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
examineSplice ::
# if MIN_VERSION_template_haskell(2,16,0)
  forall (r :: RuntimeRep) m (a :: TYPE r) .
# else
  forall m a .
# endif
  Splice m a -> m (Syntax.TExp a)
# if MIN_VERSION_template_haskell(2,17,0)
examineSplice = examineCode
# else
examineSplice :: Splice m a -> Splice m a
examineSplice = Splice m a -> Splice m a
forall a. a -> a
id
# endif

-- | A variant of 'hoistCode' that works over 'Splice's. Because this function
-- uses 'Splice', the type of this function will be different depending on
-- which version of @template-haskell@ you are using. (See the Haddocks for
-- 'Splice' for more information on this point.)
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
hoistSplice ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall m n (r :: RuntimeRep) (a :: TYPE r) .
#  else
  forall m n a .
#  endif
  Monad m => (forall x . m x -> n x) -> Splice m a -> Splice n a
# if MIN_VERSION_template_haskell(2,17,0)
hoistSplice = hoistCode
# else
hoistSplice :: (forall x. m x -> n x) -> Splice m a -> Splice n a
hoistSplice forall x. m x -> n x
f Splice m a
a = Splice m a -> Splice n a
forall x. m x -> n x
f Splice m a
a
# endif

-- | A variant of 'joinCode' that works over 'Splice's. Because this function
-- uses 'Splice', the type of this function will be different depending on
-- which version of @template-haskell@ you are using. (See the Haddocks for
-- 'Splice' for more information on this point.)
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
joinSplice ::
#  if MIN_VERSION_template_haskell(2,16,0)
  forall m (r :: RuntimeRep) (a :: TYPE r) .
#  else
  forall m a .
#  endif
  Monad m => m (Splice m a) -> Splice m a
# if MIN_VERSION_template_haskell(2,17,0)
joinSplice = joinCode
# else
joinSplice :: m (Splice m a) -> Splice m a
joinSplice = (m (Splice m a) -> (Splice m a -> Splice m a) -> Splice m a)
-> (Splice m a -> Splice m a) -> m (Splice m a) -> Splice m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (Splice m a) -> (Splice m a -> Splice m a) -> Splice m a
forall (m :: * -> *) a b.
Monad m =>
m a -> (a -> Splice m b) -> Splice m b
bindSplice Splice m a -> Splice m a
forall a. a -> a
id
# endif

-- | A variant of 'liftCode' that returns a 'Splice'. Because this function
-- returns a 'Splice', the return type of this function will be different
-- depending on which version of @template-haskell@ you are using. (See the
-- Haddocks for 'Splice' for more
-- information on this point.)
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
liftSplice ::
# if MIN_VERSION_template_haskell(2,16,0)
  forall (r :: RuntimeRep) (a :: TYPE r) m .
# else
  forall a m .
# endif
  m (Syntax.TExp a) -> Splice m a
# if MIN_VERSION_template_haskell(2,17,0)
liftSplice = liftCode
# else
liftSplice :: m (TExp a) -> m (TExp a)
liftSplice = m (TExp a) -> m (TExp a)
forall a. a -> a
id
# endif

-- | A variant of 'liftTypedQuote' that is:
--
-- 1. Always implemented in terms of 'Syntax.lift' behind the scenes, and
--
-- 2. Returns a 'Splice'. This means that the return type of this function will
--    be different depending on which version of @template-haskell@ you are
--    using. (See the Haddocks for 'Splice' for more information on this
--    point.)
--
-- This is especially useful for minimizing CPP in one particular scenario:
-- implementing 'Syntax.liftTyped' in hand-written 'Syntax.Lift' instances
-- where the corresponding 'Syntax.lift' implementation cannot be derived. For
-- instance, consider this example from the @text@ library:
--
-- @
-- instance 'Syntax.Lift' Text where
--   'Syntax.lift' = appE (varE 'pack) . stringE . unpack
-- #if MIN\_VERSION\_template\_haskell(2,17,0)
--   'Syntax.liftTyped' = 'unsafeCodeCoerce' . 'Syntax.lift'
-- #elif MIN\_VERSION\_template\_haskell(2,16,0)
--   'Syntax.liftTyped' = 'Syntax.unsafeTExpCoerce' . 'Syntax.lift'
-- #endif
-- @
--
-- The precise details of how this 'Syntax.lift' implementation works are not
-- important, only that it is something that @DeriveLift@ could not generate.
-- The main point of this example is to illustrate how tiresome it is to write
-- the CPP necessary to define 'Syntax.liftTyped' in a way that works across
-- multiple versions of @template-haskell@. With 'liftTypedFromUntypedSplice',
-- however, this becomes slightly easier to manage:
--
-- @
-- instance 'Syntax.Lift' Text where
--   'Syntax.lift' = appE (varE 'pack) . stringE . unpack
-- #if MIN\_VERSION\_template\_haskell(2,16,0)
--   'Syntax.liftTyped' = 'liftTypedFromUntypedSplice'
-- #endif
-- @
--
-- Note that due to the way this function is defined, this will only work
-- for 'Syntax.Lift' instances @t@ such that @(t :: Type)@. If you wish to
-- manually define 'Syntax.liftTyped' for a type with a different kind, you
-- will have to use 'unsafeSpliceCoerce' to overcome levity polymorphism
-- restrictions.
liftTypedFromUntypedSplice :: (Syntax.Lift t, Quote m) => t -> Splice m t
liftTypedFromUntypedSplice :: t -> Splice m t
liftTypedFromUntypedSplice = m Exp -> Splice m t
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
unsafeSpliceCoerce (m Exp -> Splice m t) -> (t -> m Exp) -> t -> Splice m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
liftQuote

-- | Unsafely convert an untyped splice representation into a typed 'Splice'
-- representation. Because this function returns a 'Splice', the return type of
-- this function will be different depending on which version of
-- @template-haskell@ you are using. (See the Haddocks for 'Splice' for more
-- information on this point.)
--
-- This is especially useful for minimizing CPP when:
--
-- 1. You need to implement 'Syntax.liftTyped' in a hand-written 'Syntax.Lift'
--    instance where the corresponding 'Syntax.lift' implementation cannot be
--    derived, and
--
-- 2. The data type receiving a 'Lift' instance has a kind besides @Type@.
--
-- Condition (2) is important because while it is possible to simply define
-- @'Syntax.liftTyped = 'liftTypedFromUntypedSplice'@ for 'Syntax.Lift'
-- instances @t@ such that @(t :: Type)@, this will not work for types with
-- different types, such as unboxed types or unlifted newtypes. This is because
-- GHC restrictions prevent defining 'liftTypedFromUntypedSplice' in a levity
-- polymorphic fashion, so one must use 'unsafeSpliceCoerce' to work around
-- these restrictions. Here is an example of how to use 'unsafeSpliceCoerce`:
--
-- @
-- instance 'Syntax.Lift' Int# where
--   'Syntax.lift' x = litE (intPrimL (fromIntegral (I# x)))
-- #if MIN\_VERSION\_template\_haskell(2,16,0)
--   'Syntax.liftTyped' x = 'unsafeSpliceCoerce' ('Syntax.lift' x)
-- #endif
-- @
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
unsafeSpliceCoerce ::
# if MIN_VERSION_template_haskell(2,16,0)
  forall (r :: RuntimeRep) (a :: TYPE r) m .
# else
  forall a m .
# endif
  Quote m => m Exp -> Splice m a
# if MIN_VERSION_template_haskell(2,17,0)
unsafeSpliceCoerce = unsafeCodeCoerce
# else
unsafeSpliceCoerce :: m Exp -> Splice m a
unsafeSpliceCoerce = m Exp -> Splice m a
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
unsafeTExpCoerceQuote
# endif

-- | A variant of 'unTypeCode' that takes a 'Splice' as an argument. Because
-- this function takes a 'Splice' as an argyment, the type of this function
-- will be different depending on which version of @template-haskell@ you are
-- using. (See the Haddocks for 'Splice' for more information on this point.)
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
unTypeSplice ::
# if MIN_VERSION_template_haskell(2,16,0)
  forall (r :: RuntimeRep) (a :: TYPE r) m .
# else
  forall a m .
# endif
  Quote m => Splice m a -> m Exp
# if MIN_VERSION_template_haskell(2,17,0)
unTypeSplice = unTypeCode
# else
unTypeSplice :: Splice m a -> m Exp
unTypeSplice = Splice m a -> m Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
unTypeQQuote
# endif
#endif

-------------------------------------------------------------------------------
-- Package root
-------------------------------------------------------------------------------

#if !MIN_VERSION_template_haskell(2,19,0)

-- | Get the package root for the current package which is being compiled.
-- This can be set explicitly with the -package-root flag but is normally
-- just the current working directory.
--
-- The motivation for this flag is to provide a principled means to remove the
-- assumption from splices that they will be executed in the directory where the
-- cabal file resides. Projects such as haskell-language-server can't and don't
-- change directory when compiling files but instead set the -package-root flag
-- appropiately.
--
-- This is best-effort compatibility implementation.
-- This function looks at the source location of the Haskell file calling it,
-- finds the first parent directory with a @.cabal@ file, and uses that as the
-- root directory for fixing the relative path.
--
getPackageRoot :: Q FilePath
getPackageRoot :: Q String
getPackageRoot = (String -> Bool) -> Q String
getPackageRootPredicate ((String -> Bool) -> Q String) -> (String -> Bool) -> Q String
forall a b. (a -> b) -> a -> b
$ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
".cabal" (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension

-- The implementation is modified from the makeRelativeToLocationPredicate
-- function in the file-embed package
-- Copyright 2008, Michael Snoyman. All rights reserved.
-- under BSD-2-Clause license.
getPackageRootPredicate :: (FilePath -> Bool) -> Q FilePath
getPackageRootPredicate :: (String -> Bool) -> Q String
getPackageRootPredicate String -> Bool
isTargetFile = do
    Loc
loc <- Q Loc
forall (m :: * -> *). Quasi m => m Loc
qLocation
    (String
srcFP, Maybe String
mdir) <- IO (String, Maybe String) -> Q (String, Maybe String)
forall a. IO a -> Q a
Syntax.runIO (IO (String, Maybe String) -> Q (String, Maybe String))
-> IO (String, Maybe String) -> Q (String, Maybe String)
forall a b. (a -> b) -> a -> b
$ do
        String
srcFP <- String -> IO String
canonicalizePath (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Loc -> String
Syntax.loc_filename Loc
loc
        Maybe String
mdir <- String -> IO (Maybe String)
findProjectDir String
srcFP
        (String, Maybe String) -> IO (String, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
srcFP, Maybe String
mdir)
    case Maybe String
mdir of
        Maybe String
Nothing  -> String -> Q String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q String) -> String -> Q String
forall a b. (a -> b) -> a -> b
$ String
"Could not find .cabal file for path: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcFP
        Just String
dir -> String -> Q String
forall (m :: * -> *) a. Monad m => a -> m a
return String
dir
  where
    findProjectDir :: String -> IO (Maybe String)
findProjectDir String
x = do
        let dir :: String
dir = String -> String
takeDirectory String
x
        if String
dir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x
        then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
        else do
            [String]
contents <- String -> IO [String]
getDirectoryContents String
dir
            if (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
isTargetFile [String]
contents
            then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
dir)
            else String -> IO (Maybe String)
findProjectDir String
dir

-- | The input is a filepath, which if relative is offset by the package root.
makeRelativeToProject :: FilePath -> Q FilePath
makeRelativeToProject :: String -> Q String
makeRelativeToProject String
fp | String -> Bool
isRelative String
fp = do
  String
root <- Q String
getPackageRoot
  String -> Q String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
root String -> String -> String
</> String
fp)
makeRelativeToProject String
fp = String -> Q String
forall (m :: * -> *) a. Monad m => a -> m a
return String
fp

#endif