diff --git a/Control/Monad/Primitive.hs b/Control/Monad/Primitive.hs index a01420bd..50ba5723 100644 --- a/Control/Monad/Primitive.hs +++ b/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,7 +30,9 @@ 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 @@ -36,7 +40,12 @@ class Monad m => PrimMonad m where -- | 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) diff --git a/primitive.cabal b/primitive.cabal index 4932fc05..388b166d 100644 --- a/primitive.cabal +++ b/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