{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Language.Haskell.TH.Instances () where
import Language.Haskell.TH hiding (newName)
import Language.Haskell.TH.Instances.Internal
import Language.Haskell.TH.Lift (deriveLiftMany)
import Language.Haskell.TH.ReifyMany
import Language.Haskell.TH.Syntax hiding (newName)
import Language.Haskell.TH.Syntax.Compat (Quote(..))
import Control.Monad.Reader (ReaderT(ReaderT), runReaderT)
import Control.Monad.RWS (RWST(RWST), runRWST)
import Control.Monad.State (StateT(StateT), runStateT)
import qualified Control.Monad.Trans as Trans (MonadTrans(lift))
import Control.Monad.Writer (WriterT(WriterT), runWriterT)
#if !(MIN_VERSION_template_haskell(2,15,0))
import Language.Haskell.TH.LanguageExtensions (Extension(..))
#endif
#if MIN_VERSION_template_haskell(2,16,0) && !(MIN_VERSION_template_haskell(2,23,0))
import GHC.Ptr (Ptr(Ptr))
import GHC.ForeignPtr (newForeignPtr_)
import Language.Haskell.TH.Syntax.Compat (liftTypedFromUntypedSplice)
import System.IO.Unsafe (unsafePerformIO)
#endif
#if !MIN_VERSION_template_haskell(2,17,0)
import Control.Applicative (liftA2)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
import Control.Monad.Fix (MonadFix (..))
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified Data.Semigroup as Semi
# if MIN_VERSION_base(4,11,0)
import Control.Exception (throwIO, catch)
import GHC.IO.Exception (BlockedIndefinitelyOnMVar (..), FixIOException (..))
# endif
#endif
#if !(MIN_VERSION_template_haskell(2,15,0))
deriving instance Bounded Extension
#endif
instance Quote m => Quote (ReaderT r m) where
newName :: String -> ReaderT r m Name
newName = m Name -> ReaderT r m Name
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m Name -> ReaderT r m Name)
-> (String -> m Name) -> String -> ReaderT r m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName
$(deriveQuasiTrans
[t| forall r m. Quasi m => Quasi (ReaderT r m) |]
[e| \m1 m2 -> ReaderT $ \ r -> runReaderT m1 r `qRecover` runReaderT m2 r |])
instance (Quote m, Monoid w) => Quote (WriterT w m) where
newName :: String -> WriterT w m Name
newName = m Name -> WriterT w m Name
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m Name -> WriterT w m Name)
-> (String -> m Name) -> String -> WriterT w m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName
$(deriveQuasiTrans
[t| forall w m. (Quasi m, Monoid w) => Quasi (WriterT w m) |]
[e| \m1 m2 -> WriterT $ runWriterT m1 `qRecover` runWriterT m2 |])
instance Quote m => Quote (StateT s m) where
newName :: String -> StateT s m Name
newName = m Name -> StateT s m Name
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m Name -> StateT s m Name)
-> (String -> m Name) -> String -> StateT s m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName
$(deriveQuasiTrans
[t| forall s m. Quasi m => Quasi (StateT s m) |]
[e| \m1 m2 -> StateT $ \ s -> runStateT m1 s `qRecover` runStateT m2 s |])
instance (Quote m, Monoid w) => Quote (RWST r w s m) where
newName :: String -> RWST r w s m Name
newName = m Name -> RWST r w s m Name
forall (m :: * -> *) a. Monad m => m a -> RWST r w s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m Name -> RWST r w s m Name)
-> (String -> m Name) -> String -> RWST r w s m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName
$(deriveQuasiTrans
[t| forall r w s m. (Quasi m, Monoid w) => Quasi (RWST r w s m) |]
[e| \m1 m2 -> RWST $ \ r s -> runRWST m1 r s `qRecover` runRWST m2 r s |])
#if MIN_VERSION_template_haskell(2,16,0) && !(MIN_VERSION_template_haskell(2,23,0))
instance Lift Bytes where
lift :: forall (m :: * -> *). Quote m => Bytes -> m Exp
lift Bytes
bytes =
[| Bytes
{ bytesPtr = unsafePerformIO $ newForeignPtr_ (Ptr $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Bytes -> Lit
BytesPrimL Bytes
bytes)))
, bytesOffset = 0
, bytesSize = size
}
|]
where
size :: Word
size = Bytes -> Word
bytesSize Bytes
bytes
liftTyped :: forall (m :: * -> *). Quote m => Bytes -> Code m Bytes
liftTyped = Bytes -> Splice m Bytes
forall t (m :: * -> *). (Lift t, Quote m) => t -> Splice m t
liftTypedFromUntypedSplice
#endif
#if !MIN_VERSION_template_haskell(2,17,0)
instance Semi.Semigroup a => Semi.Semigroup (Q a) where
(<>) = liftA2 (Semi.<>)
instance Monoid a => Monoid (Q a) where
mempty = return mempty
#if !MIN_VERSION_base(4,11,0)
mappend = liftA2 mappend
#endif
instance MonadFix Q where
mfix k = do
m <- runIO newEmptyMVar
ans <- runIO (unsafeInterleaveIO (readMVar m
#if MIN_VERSION_base(4,11,0)
`catch` \BlockedIndefinitelyOnMVar -> throwIO FixIOException
#endif
))
result <- k ans
runIO (putMVar m result)
return result
#endif
$(reifyManyWithoutInstances ''Lift [''Info, ''Loc] (const True) >>=
deriveLiftMany)