{-# LANGUAGE CPP #-}

-- | Internal module, no stability guarantees
module Control.Monad.Quote.Internal
  ( Quote (..),
    QuoteT (..),
    runQuoteT,
  )
where

import Control.Applicative
import Control.Monad (MonadPlus (..))
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Control.Monad.Fix
import Control.Monad.RWS.Class
import Control.Monad.State.Strict
import Language.Haskell.TH.Syntax (Uniq, mkNameU)
import Language.Haskell.TH.Syntax.Compat (Quote (..))

#ifdef MIN_VERSION_exceptions
import Control.Monad.Catch
#endif

#ifdef MIN_VERSION_semigroupoids
import Data.Functor.Apply (Apply (..))
import Data.Functor.Bind (Bind (..))
#endif

#ifdef MIN_VERSION_monad_control
import Control.Monad.Base
import Control.Monad.Trans.Control
#endif

-- $setup
-- >>> import Language.Haskell.TH (Exp)
-- >>> import Control.Monad.Reader

-- | The 'QuoteT' monad transformer. Also see 'runQuoteT'.
--
-- Useful to add a 'Quote' instance to any monad transformer stack.
--
-- Internally, this is a newtype of @'StateT' 'Uniq'@.
newtype QuoteT m a = QuoteT {QuoteT m a -> StateT Uniq m a
unQuoteT :: StateT Uniq m a}
  deriving newtype
    ( a -> QuoteT m b -> QuoteT m a
(a -> b) -> QuoteT m a -> QuoteT m b
(forall a b. (a -> b) -> QuoteT m a -> QuoteT m b)
-> (forall a b. a -> QuoteT m b -> QuoteT m a)
-> Functor (QuoteT m)
forall a b. a -> QuoteT m b -> QuoteT m a
forall a b. (a -> b) -> QuoteT m a -> QuoteT m b
forall (m :: * -> *) a b.
Functor m =>
a -> QuoteT m b -> QuoteT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> QuoteT m a -> QuoteT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> QuoteT m b -> QuoteT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> QuoteT m b -> QuoteT m a
fmap :: (a -> b) -> QuoteT m a -> QuoteT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> QuoteT m a -> QuoteT m b
Functor,
      Functor (QuoteT m)
a -> QuoteT m a
Functor (QuoteT m)
-> (forall a. a -> QuoteT m a)
-> (forall a b. QuoteT m (a -> b) -> QuoteT m a -> QuoteT m b)
-> (forall a b c.
    (a -> b -> c) -> QuoteT m a -> QuoteT m b -> QuoteT m c)
-> (forall a b. QuoteT m a -> QuoteT m b -> QuoteT m b)
-> (forall a b. QuoteT m a -> QuoteT m b -> QuoteT m a)
-> Applicative (QuoteT m)
QuoteT m a -> QuoteT m b -> QuoteT m b
QuoteT m a -> QuoteT m b -> QuoteT m a
QuoteT m (a -> b) -> QuoteT m a -> QuoteT m b
(a -> b -> c) -> QuoteT m a -> QuoteT m b -> QuoteT m c
forall a. a -> QuoteT m a
forall a b. QuoteT m a -> QuoteT m b -> QuoteT m a
forall a b. QuoteT m a -> QuoteT m b -> QuoteT m b
forall a b. QuoteT m (a -> b) -> QuoteT m a -> QuoteT m b
forall a b c.
(a -> b -> c) -> QuoteT m a -> QuoteT m b -> QuoteT m c
forall (m :: * -> *). Monad m => Functor (QuoteT m)
forall (m :: * -> *) a. Monad m => a -> QuoteT m a
forall (m :: * -> *) a b.
Monad m =>
QuoteT m a -> QuoteT m b -> QuoteT m a
forall (m :: * -> *) a b.
Monad m =>
QuoteT m a -> QuoteT m b -> QuoteT m b
forall (m :: * -> *) a b.
Monad m =>
QuoteT m (a -> b) -> QuoteT m a -> QuoteT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> QuoteT m a -> QuoteT m b -> QuoteT 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
<* :: QuoteT m a -> QuoteT m b -> QuoteT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
QuoteT m a -> QuoteT m b -> QuoteT m a
*> :: QuoteT m a -> QuoteT m b -> QuoteT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
QuoteT m a -> QuoteT m b -> QuoteT m b
liftA2 :: (a -> b -> c) -> QuoteT m a -> QuoteT m b -> QuoteT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> QuoteT m a -> QuoteT m b -> QuoteT m c
<*> :: QuoteT m (a -> b) -> QuoteT m a -> QuoteT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
QuoteT m (a -> b) -> QuoteT m a -> QuoteT m b
pure :: a -> QuoteT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> QuoteT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (QuoteT m)
Applicative,
      Applicative (QuoteT m)
a -> QuoteT m a
Applicative (QuoteT m)
-> (forall a b. QuoteT m a -> (a -> QuoteT m b) -> QuoteT m b)
-> (forall a b. QuoteT m a -> QuoteT m b -> QuoteT m b)
-> (forall a. a -> QuoteT m a)
-> Monad (QuoteT m)
QuoteT m a -> (a -> QuoteT m b) -> QuoteT m b
QuoteT m a -> QuoteT m b -> QuoteT m b
forall a. a -> QuoteT m a
forall a b. QuoteT m a -> QuoteT m b -> QuoteT m b
forall a b. QuoteT m a -> (a -> QuoteT m b) -> QuoteT m b
forall (m :: * -> *). Monad m => Applicative (QuoteT m)
forall (m :: * -> *) a. Monad m => a -> QuoteT m a
forall (m :: * -> *) a b.
Monad m =>
QuoteT m a -> QuoteT m b -> QuoteT m b
forall (m :: * -> *) a b.
Monad m =>
QuoteT m a -> (a -> QuoteT m b) -> QuoteT 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 -> QuoteT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> QuoteT m a
>> :: QuoteT m a -> QuoteT m b -> QuoteT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
QuoteT m a -> QuoteT m b -> QuoteT m b
>>= :: QuoteT m a -> (a -> QuoteT m b) -> QuoteT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
QuoteT m a -> (a -> QuoteT m b) -> QuoteT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (QuoteT m)
Monad,
      Monad (QuoteT m)
Monad (QuoteT m)
-> (forall a. String -> QuoteT m a) -> MonadFail (QuoteT m)
String -> QuoteT m a
forall a. String -> QuoteT m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall (m :: * -> *). MonadFail m => Monad (QuoteT m)
forall (m :: * -> *) a. MonadFail m => String -> QuoteT m a
fail :: String -> QuoteT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> QuoteT m a
$cp1MonadFail :: forall (m :: * -> *). MonadFail m => Monad (QuoteT m)
MonadFail,
      Monad (QuoteT m)
Monad (QuoteT m)
-> (forall a. IO a -> QuoteT m a) -> MonadIO (QuoteT m)
IO a -> QuoteT m a
forall a. IO a -> QuoteT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (QuoteT m)
forall (m :: * -> *) a. MonadIO m => IO a -> QuoteT m a
liftIO :: IO a -> QuoteT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> QuoteT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (QuoteT m)
MonadIO,
      Applicative (QuoteT m)
QuoteT m a
Applicative (QuoteT m)
-> (forall a. QuoteT m a)
-> (forall a. QuoteT m a -> QuoteT m a -> QuoteT m a)
-> (forall a. QuoteT m a -> QuoteT m [a])
-> (forall a. QuoteT m a -> QuoteT m [a])
-> Alternative (QuoteT m)
QuoteT m a -> QuoteT m a -> QuoteT m a
QuoteT m a -> QuoteT m [a]
QuoteT m a -> QuoteT m [a]
forall a. QuoteT m a
forall a. QuoteT m a -> QuoteT m [a]
forall a. QuoteT m a -> QuoteT m a -> QuoteT m a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall (m :: * -> *). MonadPlus m => Applicative (QuoteT m)
forall (m :: * -> *) a. MonadPlus m => QuoteT m a
forall (m :: * -> *) a. MonadPlus m => QuoteT m a -> QuoteT m [a]
forall (m :: * -> *) a.
MonadPlus m =>
QuoteT m a -> QuoteT m a -> QuoteT m a
many :: QuoteT m a -> QuoteT m [a]
$cmany :: forall (m :: * -> *) a. MonadPlus m => QuoteT m a -> QuoteT m [a]
some :: QuoteT m a -> QuoteT m [a]
$csome :: forall (m :: * -> *) a. MonadPlus m => QuoteT m a -> QuoteT m [a]
<|> :: QuoteT m a -> QuoteT m a -> QuoteT m a
$c<|> :: forall (m :: * -> *) a.
MonadPlus m =>
QuoteT m a -> QuoteT m a -> QuoteT m a
empty :: QuoteT m a
$cempty :: forall (m :: * -> *) a. MonadPlus m => QuoteT m a
$cp1Alternative :: forall (m :: * -> *). MonadPlus m => Applicative (QuoteT m)
Alternative,
      Monad (QuoteT m)
Alternative (QuoteT m)
QuoteT m a
Alternative (QuoteT m)
-> Monad (QuoteT m)
-> (forall a. QuoteT m a)
-> (forall a. QuoteT m a -> QuoteT m a -> QuoteT m a)
-> MonadPlus (QuoteT m)
QuoteT m a -> QuoteT m a -> QuoteT m a
forall a. QuoteT m a
forall a. QuoteT m a -> QuoteT m a -> QuoteT m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
forall (m :: * -> *). MonadPlus m => Monad (QuoteT m)
forall (m :: * -> *). MonadPlus m => Alternative (QuoteT m)
forall (m :: * -> *) a. MonadPlus m => QuoteT m a
forall (m :: * -> *) a.
MonadPlus m =>
QuoteT m a -> QuoteT m a -> QuoteT m a
mplus :: QuoteT m a -> QuoteT m a -> QuoteT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
QuoteT m a -> QuoteT m a -> QuoteT m a
mzero :: QuoteT m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => QuoteT m a
$cp2MonadPlus :: forall (m :: * -> *). MonadPlus m => Monad (QuoteT m)
$cp1MonadPlus :: forall (m :: * -> *). MonadPlus m => Alternative (QuoteT m)
MonadPlus,
      Monad (QuoteT m)
Monad (QuoteT m)
-> (forall a. (a -> QuoteT m a) -> QuoteT m a)
-> MonadFix (QuoteT m)
(a -> QuoteT m a) -> QuoteT m a
forall a. (a -> QuoteT m a) -> QuoteT m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (QuoteT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> QuoteT m a) -> QuoteT m a
mfix :: (a -> QuoteT m a) -> QuoteT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> QuoteT m a) -> QuoteT m a
$cp1MonadFix :: forall (m :: * -> *). MonadFix m => Monad (QuoteT m)
MonadFix,
      m a -> QuoteT m a
(forall (m :: * -> *) a. Monad m => m a -> QuoteT m a)
-> MonadTrans QuoteT
forall (m :: * -> *) a. Monad m => m a -> QuoteT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> QuoteT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> QuoteT m a
MonadTrans,
      MonadReader r,
      MonadWriter w,
      MonadRWS r w s,
      Monad (QuoteT m)
Monad (QuoteT m)
-> (forall a b. ((a -> QuoteT m b) -> QuoteT m a) -> QuoteT m a)
-> MonadCont (QuoteT m)
((a -> QuoteT m b) -> QuoteT m a) -> QuoteT m a
forall a b. ((a -> QuoteT m b) -> QuoteT m a) -> QuoteT m a
forall (m :: * -> *).
Monad m -> (forall a b. ((a -> m b) -> m a) -> m a) -> MonadCont m
forall (m :: * -> *). MonadCont m => Monad (QuoteT m)
forall (m :: * -> *) a b.
MonadCont m =>
((a -> QuoteT m b) -> QuoteT m a) -> QuoteT m a
callCC :: ((a -> QuoteT m b) -> QuoteT m a) -> QuoteT m a
$ccallCC :: forall (m :: * -> *) a b.
MonadCont m =>
((a -> QuoteT m b) -> QuoteT m a) -> QuoteT m a
$cp1MonadCont :: forall (m :: * -> *). MonadCont m => Monad (QuoteT m)
MonadCont,
      MonadError e
    )

#ifdef MIN_VERSION_exceptions
  deriving newtype (MonadThrow, MonadCatch, MonadMask)
#endif

#ifdef MIN_VERSION_semigroupoids
  deriving newtype (Apply)
#endif

#ifdef MIN_VERSION_monad_control
  deriving newtype (MonadBase b, MonadBaseControl b, MonadTransControl)
#endif

instance MonadState s m => MonadState s (QuoteT m) where
  get :: QuoteT m s
get = m s -> QuoteT m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> QuoteT m ()
put = m () -> QuoteT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> QuoteT m ()) -> (s -> m ()) -> s -> QuoteT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
  state :: (s -> (a, s)) -> QuoteT m a
state = m a -> QuoteT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> QuoteT m a)
-> ((s -> (a, s)) -> m a) -> (s -> (a, s)) -> QuoteT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> (a, s)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state

instance Monad m => Quote (QuoteT m) where
  newName :: String -> QuoteT m Name
newName String
s = StateT Uniq m Name -> QuoteT m Name
forall (m :: * -> *) a. StateT Uniq m a -> QuoteT m a
QuoteT (StateT Uniq m Name -> QuoteT m Name)
-> ((Uniq -> (Name, Uniq)) -> StateT Uniq m Name)
-> (Uniq -> (Name, Uniq))
-> QuoteT m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uniq -> (Name, Uniq)) -> StateT Uniq m Name
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((Uniq -> (Name, Uniq)) -> QuoteT m Name)
-> (Uniq -> (Name, Uniq)) -> QuoteT m Name
forall a b. (a -> b) -> a -> b
$ \Uniq
i -> (String -> Uniq -> Name
mkNameU String
s Uniq
i, Uniq
i Uniq -> Uniq -> Uniq
forall a. Num a => a -> a -> a
+ Uniq
1)

#ifdef MIN_VERSION_semigroupoids
instance Bind m => Bind (QuoteT m) where
  QuoteT sma >>- f = QuoteT $ sma >>- unQuoteT . f
#endif

-- | Extract @m a@ from @'QuoteT' m a@, where @'QuoteT' m@ is always an instance of 'Quote'.
--
-- On GHC 9.0+, you can use this to extract an 'Language.Haskell.TH.Exp' out of a quotation bracket:
--
-- >>> import qualified Language.Haskell.TH.Lib as TH
-- >>> :{
-- let mExp :: (Quote m, MonadReader String m) => m Exp
--     mExp = [| \a -> a <> $(TH.stringE =<< ask) |]
--     exp :: Exp
--     exp = flip runReader " world" . runQuoteT $ mExp
--  in exp
-- :}
-- LamE [VarP a_0] (InfixE (Just (VarE a_0)) (VarE GHC.Base.<>) (Just (LitE (StringL " world"))))
runQuoteT :: Monad m => QuoteT m a -> m a
runQuoteT :: QuoteT m a -> m a
runQuoteT = (StateT Uniq m a -> Uniq -> m a) -> Uniq -> StateT Uniq m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Uniq m a -> Uniq -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Uniq
0 (StateT Uniq m a -> m a)
-> (QuoteT m a -> StateT Uniq m a) -> QuoteT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuoteT m a -> StateT Uniq m a
forall (m :: * -> *) a. QuoteT m a -> StateT Uniq m a
unQuoteT