Add Tagged Effect (#223)

polysemy.cabal

@@ -76,6 +76,7 @@ library
       Polysemy.Reader
       Polysemy.Resource
       Polysemy.State
+      Polysemy.Tagged
       Polysemy.Trace
       Polysemy.Writer
   other-modules:

src/Polysemy/Tagged.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Polysemy.Tagged
+  (
+    -- * Effect
+    Tagged (..)
+
+    -- * Actions
+  , tag
+
+    -- * Interpretations
+  , untag
+  , retag
+  ) where
+
+import Polysemy
+import Polysemy.Internal
+import Polysemy.Internal.Union
+
+
+------------------------------------------------------------------------------
+-- | An effect for annotating effects and disambiguating identical effects.
+newtype Tagged k e m a where
+  Tagged :: forall k e m a. e m a -> Tagged k e m a
+
+------------------------------------------------------------------------------
+-- | Tag uses of an effect, effectively gaining access to the
+-- tagged effect locally.
+--
+-- This may be used to create @tagged-@ variants of regular actions.
+--
+-- For example:
+--
+-- @
+-- taggedLocal :: forall k i r a
+--              . 'Member' ('Tagged' k ('Polysemy.Reader.Reader' i)) r
+--             => (i -> i)
+--             -> 'Sem' r a
+--             -> 'Sem' r a
+-- taggedLocal f m =
+--   'tag' @k @('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m)
+-- @
+--
+tag :: forall k e r a
+     . Member (Tagged k e) r
+    => Sem (e ': r) a
+    -> Sem r a
+tag = hoistSem $ \u -> case decomp u of
+  Right (Weaving e s wv ex ins) ->
+    injWeaving $ Weaving (Tagged @k e) s (tag @k . wv) ex ins
+  Left g -> hoist (tag @k) g
+{-# INLINE tag #-}
+
+------------------------------------------------------------------------------
+-- | Run a @'Tagged' k e@ effect through reinterpreting it to @e@
+untag :: forall k e r a
+       . Sem (Tagged k e ': r) a
+      -> Sem (e ': r) a
+-- TODO(KingoftheHomeless): I think this is safe to replace with 'unsafeCoerce',
+-- but doing so probably worsens performance, as it hampers optimizations.
+-- Once GHC 8.10 rolls out, I will benchmark and compare.
+untag = hoistSem $ \u -> case decompCoerce u of
+  Right (Weaving (Tagged e) s wv ex ins) ->
+    Union SZ (Weaving e s (untag . wv) ex ins)
+  Left g -> hoist untag g
+{-# INLINE untag #-}
+
+------------------------------------------------------------------------------
+-- | Transform a @'Tagged' k1 e@ effect into a @'Tagged' k2 e@ effect
+retag :: forall k1 k2 e r a
+       . Member (Tagged k2 e) r
+      => Sem (Tagged k1 e ': r) a
+      -> Sem r a
+retag = hoistSem $ \u -> case decomp u of
+  Right (Weaving (Tagged e) s wv ex ins) ->
+    injWeaving $ Weaving (Tagged @k2 e) s (retag @_ @k2 . wv) ex ins
+  Left g -> hoist (retag @_ @k2) g
+{-# INLINE retag #-}
+