Split off PrimMonadInternal haskell/vector#65

Control/Monad/Primitive.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP, MagicHash, UnboxedTuples, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
 
 -- |
 -- Module      : Control.Monad.Primitive
@@ -13,6 +14,7 @@
 
 module Control.Monad.Primitive (
   PrimMonad(..), RealWorld, primitive_,
+  PrimMonadInternal(..),
   primToPrim, primToIO, primToST,
   unsafePrimToPrim, unsafePrimToIO, unsafePrimToST,
   unsafeInlinePrim, unsafeInlineIO, unsafeInlineST,
@@ -28,15 +30,22 @@ import GHC.IOBase ( IO(..) )
 #endif
 import GHC.ST     ( ST(..) )
 
--- | Class of primitive state-transformer monads
+import Control.Monad.Trans.Class (MonadTrans, lift)
+
+-- | 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@.
+class PrimMonad m => PrimMonadInternal m where
   -- | Expose the internal structure of the monad
   internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)
 
@@ -48,54 +57,59 @@ primitive_ f = primitive (\s# ->
     case f s# of
         s'# -> (# s'#, () #))
 
+instance (MonadTrans t, PrimMonad m, Monad (t m)) => PrimMonad (t m) where
+  type PrimState (t m) = PrimState m
+  primitive = lift . primitive
 instance PrimMonad IO where
   type PrimState IO = RealWorld
   primitive = IO
-  internal (IO p) = p
   {-# INLINE primitive #-}
+instance PrimMonadInternal IO where
+  internal (IO p) = p
   {-# INLINE internal #-}
 
 instance PrimMonad (ST s) where
   type PrimState (ST s) = s
   primitive = ST
-  internal (ST p) = p
   {-# INLINE primitive #-}
+instance PrimMonadInternal (ST s) where
+  internal (ST p) = p
   {-# INLINE internal #-}
 
 -- | Convert a 'PrimMonad' to another monad with the same state token.
-primToPrim :: (PrimMonad m1, PrimMonad m2, PrimState m1 ~ PrimState m2)
+primToPrim :: (PrimMonadInternal m1, PrimMonad m2, PrimState m1 ~ PrimState m2)
         => m1 a -> m2 a
 {-# INLINE primToPrim #-}
 primToPrim m = primitive (internal m)
 
 -- | Convert a 'PrimMonad' with a 'RealWorld' state token to 'IO'
-primToIO :: (PrimMonad m, PrimState m ~ RealWorld) => m a -> IO a
+primToIO :: (PrimMonadInternal m, PrimState m ~ RealWorld) => m a -> IO a
 {-# INLINE primToIO #-}
 primToIO = primToPrim
 
 -- | Convert a 'PrimMonad' to 'ST'
-primToST :: PrimMonad m => m a -> ST (PrimState m) a
+primToST :: PrimMonadInternal m => m a -> ST (PrimState m) a
 {-# INLINE primToST #-}
 primToST = primToPrim
 
 -- | Convert a 'PrimMonad' to another monad with a possibly different state
 -- token. This operation is highly unsafe!
-unsafePrimToPrim :: (PrimMonad m1, PrimMonad m2) => m1 a -> m2 a
+unsafePrimToPrim :: (PrimMonadInternal m1, PrimMonad m2) => m1 a -> m2 a
 {-# INLINE unsafePrimToPrim #-}
 unsafePrimToPrim m = primitive (unsafeCoerce# (internal m))
 
 -- | Convert any 'PrimMonad' to 'ST' with an arbitrary state token. This
 -- operation is highly unsafe!
-unsafePrimToST :: PrimMonad m => m a -> ST s a
+unsafePrimToST :: PrimMonadInternal m => m a -> ST s a
 {-# INLINE unsafePrimToST #-}
 unsafePrimToST = unsafePrimToPrim
 
 -- | Convert any 'PrimMonad' to 'IO'. This operation is highly unsafe!
-unsafePrimToIO :: PrimMonad m => m a -> IO a
+unsafePrimToIO :: PrimMonadInternal m => m a -> IO a
 {-# INLINE unsafePrimToIO #-}
 unsafePrimToIO = unsafePrimToPrim
 
-unsafeInlinePrim :: PrimMonad m => m a -> a
+unsafeInlinePrim :: PrimMonadInternal m => m a -> a
 {-# INLINE unsafeInlinePrim #-}
 unsafeInlinePrim m = unsafeInlineIO (unsafePrimToIO m)
 

primitive.cabal

@@ -36,7 +36,9 @@ Library
         Data.Primitive.Internal.Compat
         Data.Primitive.Internal.Operations
 
-  Build-Depends: base >= 4.3 && < 4.9, ghc-prim >= 0.2 && < 0.4
+  Build-Depends: base >= 4.3 && < 4.9
+               , ghc-prim >= 0.2 && < 0.4
+               , transformers >= 0.2 && < 0.5
 
   Ghc-Options: -O2 -Wall