content: {-# LANGUAGE CPP, MagicHash, UnboxedTuples, TypeFamilies #-}
  {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE DataKinds #-}
  #if __GLASGOW_HASKELL__ < 806
  {-# LANGUAGE TypeInType #-}
  #endif
  {-# OPTIONS_GHC -fno-warn-deprecations #-}
  
  -- |
  -- Module      : Control.Monad.Primitive
  -- Copyright   : (c) Roman Leshchinskiy 2009
  -- License     : BSD-style
  --
  -- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
  -- Portability : non-portable
  --
  -- Primitive state-transformer monads.
  
  module Control.Monad.Primitive (
    PrimMonad(..), RealWorld, primitive_,
    PrimBase(..),
    MonadPrim,
    MonadPrimBase,
    liftPrim, primToPrim, primToIO, primToST, ioToPrim, stToPrim,
    unsafePrimToPrim, unsafePrimToIO, unsafePrimToST, unsafeIOToPrim,
    unsafeSTToPrim, unsafeInlinePrim, unsafeInlineIO, unsafeInlineST,
    touch, touchUnlifted,
    keepAlive, keepAliveUnlifted,
    evalPrim, unsafeInterleave, unsafeDupableInterleave, noDuplicate
  ) where
  
  import Data.Kind (Type)
  
  import GHC.Exts   ( State#, RealWorld, noDuplicate#, touch#
                    , unsafeCoerce#, realWorld#, seq# )
  import Data.Primitive.Internal.Operations (UnliftedType)
  #if defined(HAVE_KEEPALIVE)
  import Data.Primitive.Internal.Operations (keepAliveLiftedLifted#,keepAliveUnliftedLifted#)
  #endif
  import GHC.IO     ( IO(..) )
  import GHC.ST     ( ST(..) )
  
  #if __GLASGOW_HASKELL__ >= 802
  import qualified Control.Monad.ST.Lazy as L
  #endif
  
  import Control.Monad.Trans.Class (lift)
  
  import Control.Monad.Trans.Cont     ( ContT    )
  import Control.Monad.Trans.Identity ( IdentityT (IdentityT) )
  import Control.Monad.Trans.Maybe    ( MaybeT   )
  import Control.Monad.Trans.Reader   ( ReaderT  )
  import Control.Monad.Trans.State    ( StateT   )
  import Control.Monad.Trans.Writer   ( WriterT  )
  import Control.Monad.Trans.RWS      ( RWST     )
  
  #if !MIN_VERSION_transformers(0,6,0)
  import Control.Monad.Trans.List     ( ListT    )
  import Control.Monad.Trans.Error    ( ErrorT, Error)
  #endif
  
  import Control.Monad.Trans.Except   ( ExceptT  )
  
  #if MIN_VERSION_transformers(0,5,3)
  import Control.Monad.Trans.Accum    ( AccumT   )
  import Control.Monad.Trans.Select   ( SelectT  )
  #endif
  
  #if MIN_VERSION_transformers(0,5,6)
  import qualified Control.Monad.Trans.Writer.CPS as CPS
  import qualified Control.Monad.Trans.RWS.CPS as CPS
  #endif
  
  import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )
  import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )
  import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
  
  -- | Class of monads which can perform primitive state-transformer actions.
  class Monad m => PrimMonad m where
    -- | State token type.
    type PrimState m
  
    -- | Execute a primitive operation.
    primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
  
  -- | Class of primitive monads for state-transformer actions.
  --
  -- Unlike 'PrimMonad', this typeclass requires that the @Monad@ be fully
  -- expressed as a state transformer, therefore disallowing other monad
  -- transformers on top of the base @IO@ or @ST@.
  --
  -- @since 0.6.0.0
  class PrimMonad m => PrimBase m where
    -- | Expose the internal structure of the monad.
    internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)
  
  -- | Execute a primitive operation with no result.
  primitive_ :: PrimMonad m
                => (State# (PrimState m) -> State# (PrimState m)) -> m ()
  {-# INLINE primitive_ #-}
  primitive_ f = primitive (\s# ->
      case f s# of
          s'# -> (# s'#, () #))
  
  instance PrimMonad IO where
    type PrimState IO = RealWorld
    primitive = IO
    {-# INLINE primitive #-}
  
  instance PrimBase IO where
    internal (IO p) = p
    {-# INLINE internal #-}
  
  -- | @since 0.6.3.0
  instance PrimMonad m => PrimMonad (ContT r m) where
    type PrimState (ContT r m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  instance PrimMonad m => PrimMonad (IdentityT m) where
    type PrimState (IdentityT m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  -- | @since 0.6.2.0
  instance PrimBase m => PrimBase (IdentityT m) where
    internal (IdentityT m) = internal m
    {-# INLINE internal #-}
  
  #if !MIN_VERSION_transformers(0,6,0)
  instance PrimMonad m => PrimMonad (ListT m) where
    type PrimState (ListT m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  instance (Error e, PrimMonad m) => PrimMonad (ErrorT e m) where
    type PrimState (ErrorT e m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  #endif
  
  instance PrimMonad m => PrimMonad (MaybeT m) where
    type PrimState (MaybeT m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  instance PrimMonad m => PrimMonad (ReaderT r m) where
    type PrimState (ReaderT r m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  instance PrimMonad m => PrimMonad (StateT s m) where
    type PrimState (StateT s m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  instance (Monoid w, PrimMonad m) => PrimMonad (WriterT w m) where
    type PrimState (WriterT w m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  #if MIN_VERSION_transformers(0,5,6)
  instance (Monoid w, PrimMonad m) => PrimMonad (CPS.WriterT w m) where
    type PrimState (CPS.WriterT w m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  #endif
  
  instance (Monoid w, PrimMonad m) => PrimMonad (RWST r w s m) where
    type PrimState (RWST r w s m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  #if MIN_VERSION_transformers(0,5,6)
  instance (Monoid w, PrimMonad m) => PrimMonad (CPS.RWST r w s m) where
    type PrimState (CPS.RWST r w s m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  #endif
  
  instance PrimMonad m => PrimMonad (ExceptT e m) where
    type PrimState (ExceptT e m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  #if MIN_VERSION_transformers(0,5,3)
  -- | @since 0.6.3.0
  instance ( Monoid w
           , PrimMonad m
           ) => PrimMonad (AccumT w m) where
    type PrimState (AccumT w m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  instance PrimMonad m => PrimMonad (SelectT r m) where
    type PrimState (SelectT r m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  #endif
  
  instance PrimMonad m => PrimMonad (Strict.StateT s m) where
    type PrimState (Strict.StateT s m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  instance (Monoid w, PrimMonad m) => PrimMonad (Strict.WriterT w m) where
    type PrimState (Strict.WriterT w m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  instance (Monoid w, PrimMonad m) => PrimMonad (Strict.RWST r w s m) where
    type PrimState (Strict.RWST r w s m) = PrimState m
    primitive = lift . primitive
    {-# INLINE primitive #-}
  
  instance PrimMonad (ST s) where
    type PrimState (ST s) = s
    primitive = ST
    {-# INLINE primitive #-}
  
  instance PrimBase (ST s) where
    internal (ST p) = p
    {-# INLINE internal #-}
  
  -- see https://gitlab.haskell.org/ghc/ghc/commit/2f5cb3d44d05e581b75a47fec222577dfa7a533e
  -- for why we only support an instance for ghc >= 8.2
  #if __GLASGOW_HASKELL__ >= 802
  -- @since 0.7.1.0
  instance PrimMonad (L.ST s) where
    type PrimState (L.ST s) = s
    primitive = L.strictToLazyST . primitive
    {-# INLINE primitive #-}
  
  -- @since 0.7.1.0
  instance PrimBase (L.ST s) where
    internal = internal . L.lazyToStrictST
    {-# INLINE internal #-}
  #endif
  
  -- | 'PrimMonad''s state token type can be annoying to handle
  --   in constraints. This typeclass lets users (visually) notice
  --   'PrimState' equality constraints less, by witnessing that
  --   @s ~ 'PrimState' m@.
  class (PrimMonad m, s ~ PrimState m) => MonadPrim s m
  instance (PrimMonad m, s ~ PrimState m) => MonadPrim s m
  
  -- | 'PrimBase''s state token type can be annoying to handle
  --   in constraints. This typeclass lets users (visually) notice
  --   'PrimState' equality constraints less, by witnessing that
  --   @s ~ 'PrimState' m@.
  class (PrimBase m, MonadPrim s m) => MonadPrimBase s m
  instance (PrimBase m, MonadPrim s m) => MonadPrimBase s m
  
  -- | Lifts a 'PrimBase' into another 'PrimMonad' with the same underlying state
  -- token type.
  liftPrim
    :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) => m1 a -> m2 a
  {-# INLINE liftPrim #-}
  liftPrim = primToPrim
  
  -- | Convert a 'PrimBase' to another monad with the same state token.
  primToPrim :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2)
          => m1 a -> m2 a
  {-# INLINE primToPrim #-}
  primToPrim m = primitive (internal m)
  
  -- | Convert a 'PrimBase' with a 'RealWorld' state token to 'IO'
  primToIO :: (PrimBase m, PrimState m ~ RealWorld) => m a -> IO a
  {-# INLINE primToIO #-}
  primToIO = primToPrim
  
  -- | Convert a 'PrimBase' to 'ST'
  primToST :: PrimBase m => m a -> ST (PrimState m) a
  {-# INLINE primToST #-}
  primToST = primToPrim
  
  -- | Convert an 'IO' action to a 'PrimMonad'.
  --
  -- @since 0.6.2.0
  ioToPrim :: (PrimMonad m, PrimState m ~ RealWorld) => IO a -> m a
  {-# INLINE ioToPrim #-}
  ioToPrim = primToPrim
  
  -- | Convert an 'ST' action to a 'PrimMonad'.
  --
  -- @since 0.6.2.0
  stToPrim :: PrimMonad m => ST (PrimState m) a -> m a
  {-# INLINE stToPrim #-}
  stToPrim = primToPrim
  
  -- | Convert a 'PrimBase' to another monad with a possibly different state
  -- token. This operation is highly unsafe!
  unsafePrimToPrim :: (PrimBase m1, PrimMonad m2) => m1 a -> m2 a
  {-# INLINE unsafePrimToPrim #-}
  unsafePrimToPrim m = primitive (unsafeCoerce# (internal m))
  
  -- | Convert any 'PrimBase' to 'ST' with an arbitrary state token. This
  -- operation is highly unsafe!
  unsafePrimToST :: PrimBase m => m a -> ST s a
  {-# INLINE unsafePrimToST #-}
  unsafePrimToST = unsafePrimToPrim
  
  -- | Convert any 'PrimBase' to 'IO'. This operation is highly unsafe!
  unsafePrimToIO :: PrimBase m => m a -> IO a
  {-# INLINE unsafePrimToIO #-}
  unsafePrimToIO = unsafePrimToPrim
  
  -- | Convert an 'ST' action with an arbitrary state token to any 'PrimMonad'.
  -- This operation is highly unsafe!
  --
  -- @since 0.6.2.0
  unsafeSTToPrim :: PrimMonad m => ST s a -> m a
  {-# INLINE unsafeSTToPrim #-}
  unsafeSTToPrim = unsafePrimToPrim
  
  -- | Convert an 'IO' action to any 'PrimMonad'. This operation is highly
  -- unsafe!
  --
  -- @since 0.6.2.0
  unsafeIOToPrim :: PrimMonad m => IO a -> m a
  {-# INLINE unsafeIOToPrim #-}
  unsafeIOToPrim = unsafePrimToPrim
  
  -- | See 'unsafeInlineIO'. This function is not recommended for the same
  -- reasons.
  unsafeInlinePrim :: PrimBase m => m a -> a
  {-# INLINE unsafeInlinePrim #-}
  unsafeInlinePrim m = unsafeInlineIO (unsafePrimToIO m)
  
  -- | Generally, do not use this function. It is the same as
  -- @accursedUnutterablePerformIO@ from @bytestring@ and is well behaved under
  -- narrow conditions. See the documentation of that function to get an idea
  -- of when this is sound. In most cases @GHC.IO.Unsafe.unsafeDupablePerformIO@
  -- should be preferred.
  unsafeInlineIO :: IO a -> a
  {-# INLINE unsafeInlineIO #-}
  unsafeInlineIO m = case internal m realWorld# of (# _, r #) -> r
  
  -- | See 'unsafeInlineIO'. This function is not recommended for the same
  -- reasons. Prefer @runST@ when @s@ is free.
  unsafeInlineST :: ST s a -> a
  {-# INLINE unsafeInlineST #-}
  unsafeInlineST = unsafeInlinePrim
  
  -- | Ensure that the value is considered alive by the garbage collection.
  -- Warning: GHC has optimization passes that can erase @touch@ if it is
  -- certain that an exception is thrown afterward. Prefer 'keepAlive'.
  touch :: PrimMonad m => a -> m ()
  {-# INLINE touch #-}
  touch x = unsafePrimToPrim
          $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ())
  
  -- | Variant of 'touch' that keeps a value of an unlifted type
  -- (e.g. @MutableByteArray#@) alive.
  touchUnlifted :: forall (m :: Type -> Type) (a :: UnliftedType). PrimMonad m => a -> m ()
  {-# INLINE touchUnlifted #-}
  touchUnlifted x = unsafePrimToPrim
          $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ())
  
  -- | Keep value @x@ alive until computation @k@ completes.
  -- Warning: This primop exists for completeness, but it is difficult to use
  -- correctly. Prefer 'keepAliveUnlifted' if the value to keep alive is simply
  -- a wrapper around an unlifted type (e.g. @ByteArray@).
  keepAlive :: PrimBase m
    => a -- ^ Value @x@ to keep alive while computation @k@ runs.
    -> m r -- ^ Computation @k@
    -> m r
  #if defined(HAVE_KEEPALIVE)
  {-# INLINE keepAlive #-}
  keepAlive x k =
    primitive $ \s0 -> keepAliveLiftedLifted# x s0 (internal k)
  
  #else
  {-# NOINLINE keepAlive #-}
  keepAlive x k = k <* touch x
  #endif
  
  -- | Variant of 'keepAlive' in which the value kept alive is of an unlifted
  -- boxed type.
  keepAliveUnlifted :: forall (m :: Type -> Type) (a :: UnliftedType) (r :: Type). PrimBase m => a -> m r -> m r
  #if defined(HAVE_KEEPALIVE)
  {-# INLINE keepAliveUnlifted #-}
  keepAliveUnlifted x k =
    primitive $ \s0 -> keepAliveUnliftedLifted# x s0 (internal k)
  
  #else
  {-# NOINLINE keepAliveUnlifted #-}
  keepAliveUnlifted x k = k <* touchUnlifted x
  #endif
  
  -- | Create an action to force a value; generalizes 'Control.Exception.evaluate'
  --
  -- @since 0.6.2.0
  evalPrim :: forall a m . PrimMonad m => a -> m a
  evalPrim a = primitive (\s -> seq# a s)
  
  noDuplicate :: PrimMonad m => m ()
  #if __GLASGOW_HASKELL__ >= 802
  noDuplicate = primitive $ \ s -> (# noDuplicate# s, () #)
  #else
  -- noDuplicate# was limited to RealWorld
  noDuplicate = unsafeIOToPrim $ primitive $ \s -> (# noDuplicate# s, () #)
  #endif
  
  unsafeInterleave, unsafeDupableInterleave :: PrimBase m => m a -> m a
  unsafeInterleave x = unsafeDupableInterleave (noDuplicate >> x)
  unsafeDupableInterleave x = primitive $ \ s -> let r' = case internal x s of (# _, r #) -> r in (# s, r' #)
  {-# INLINE unsafeInterleave #-}
  {-# NOINLINE unsafeDupableInterleave #-}
  -- See Note [unsafeDupableInterleaveIO should not be inlined]
  -- in GHC.IO.Unsafe
  