diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,11 @@
 # Revision history for ecstasy
 
+## 0.2.1.0  -- 2018-05-15
+
+* Added the 'surgery' function to introduce temporary effects.
+* Significant performance improvements due to constructing monadic generic
+    functions via 'Codensity'.
+
 ## 0.2.0.1  -- 2018-05-10
 
 * Also export 'StorageType'.
diff --git a/ecstasy.cabal b/ecstasy.cabal
--- a/ecstasy.cabal
+++ b/ecstasy.cabal
@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                ecstasy
-version:             0.2.0.1
+version:             0.2.1.0
 synopsis:
   A GHC.Generics based entity component system.
 
@@ -39,6 +39,6 @@
                  , Data.Ecstasy.Internal
                  , Data.Ecstasy.Internal.Deriving
   -- other-extensions:
-  build-depends:       base >=4.9 && <5, containers, mtl, transformers
+  build-depends:       base >=4.9 && <5, containers, mtl, transformers, kan-extensions
   hs-source-dirs:      src
   default-language:    Haskell2010
diff --git a/src/Data/Ecstasy.hs b/src/Data/Ecstasy.hs
--- a/src/Data/Ecstasy.hs
+++ b/src/Data/Ecstasy.hs
@@ -89,6 +89,9 @@
   , Update (..)
   , maybeToUpdate
 
+  -- * Introducing effects
+  , surgery
+
   -- * Miscellany
   , Ent ()
   , VTable (..)
@@ -153,7 +156,7 @@
 --              }
 --          }
 --    'runSystemT' storage $ do
---      void $ 'createEntity' 'unchanged
+--      void $ 'createEntity' 'newEntity'
 --        { stdout = Just "hello world"
 --        }
 -- @
diff --git a/src/Data/Ecstasy/Internal.hs b/src/Data/Ecstasy/Internal.hs
--- a/src/Data/Ecstasy/Internal.hs
+++ b/src/Data/Ecstasy/Internal.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MonoLocalBinds         #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE RankNTypes             #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
 {-# LANGUAGE TupleSections          #-}
 {-# LANGUAGE TypeApplications       #-}
@@ -16,10 +17,11 @@
 
 import           Control.Arrow (first, second)
 import           Control.Monad (mzero, void)
-import           Control.Monad.Trans.Class (lift)
+import           Control.Monad.Codensity (lowerCodensity)
+import           Control.Monad.Trans.Class (MonadTrans (..))
 import           Control.Monad.Trans.Maybe (runMaybeT)
 import           Control.Monad.Trans.Reader (runReaderT, asks)
-import           Control.Monad.Trans.State.Strict (modify, get, gets, evalStateT)
+import           Control.Monad.Trans.State.Strict (StateT (..), modify, get, gets, evalStateT)
 import qualified Control.Monad.Trans.State.Strict as S
 import           Data.Ecstasy.Internal.Deriving
 import qualified Data.Ecstasy.Types as T
@@ -55,7 +57,10 @@
       -> SystemT world m (world 'FieldOf)
   getEntity e = do
     w <- SystemT $ gets snd
-    lift . fmap to . gGetEntity @m (from w) $ T.unEnt e
+    lift . lowerCodensity
+         . fmap to
+         . gGetEntity @m (from w)
+         $ T.unEnt e
   {-# INLINE getEntity #-}
 
   ----------------------------------------------------------------------------
@@ -77,7 +82,10 @@
       -> SystemT world m ()
   setEntity e s = do
     w <- SystemT $ gets snd
-    x <- lift . fmap to . gSetEntity (from s) (T.unEnt e) $ from w
+    x <- lift . lowerCodensity
+              . fmap to
+              . gSetEntity (from s) (T.unEnt e)
+              $ from w
     SystemT . modify . second $ const x
   {-# INLINE setEntity #-}
 
@@ -90,6 +98,7 @@
          )
       => world ('WorldOf m)
   defStorage = def @'True
+  {-# INLINE defStorage #-}
 
 
 class HasWorld' world where
@@ -172,6 +181,84 @@
                       (Rep (world 'FieldOf))
          , Monad m
          ) => HasWorld world m
+
+
+------------------------------------------------------------------------------
+-- | Utilities for defining 'surgery'.
+class StorageSurgeon t m world where
+  ----------------------------------------------------------------------------
+  -- | Hoist storage through a monad transformer.
+  hoistStorage
+    :: world ('WorldOf m)
+    -> world ('WorldOf (t m))
+  default hoistStorage
+    :: ( Generic (world ('WorldOf m))
+       , Generic (world ('WorldOf (t m)))
+       , GHoistWorld t m
+                     (Rep (world ('WorldOf m)))
+                     (Rep (world ('WorldOf (t m))))
+       , MonadTrans t
+       )
+    => world ('WorldOf m)
+    -> world ('WorldOf (t m))
+  hoistStorage = to . gHoistWorld @t @m . from
+  {-# INLINE hoistStorage #-}
+
+  ----------------------------------------------------------------------------
+  -- | Grafts two worlds together, using data from the second argument and
+  -- vtables from the first.
+  graftStorage
+    :: world ('WorldOf m)
+    -> world ('WorldOf (t m))
+    -> world ('WorldOf m)
+  default graftStorage
+    :: ( Generic (world ('WorldOf m))
+       , Generic (world ('WorldOf (t m)))
+       , GGraft (Rep (world ('WorldOf m)))
+                (Rep (world ('WorldOf (t m))))
+       )
+    => world ('WorldOf m)
+    -> world ('WorldOf (t m))
+    -> world ('WorldOf m)
+  graftStorage a b = to $ gGraft (from a) (from b)
+  {-# INLINE graftStorage #-}
+
+
+instance ( Generic (world ('WorldOf m))
+         , Generic (world ('WorldOf (t m)))
+         , GHoistWorld t m (Rep (world ('WorldOf m)))
+                           (Rep (world ('WorldOf (t m))))
+         , GGraft (Rep (world ('WorldOf m)))
+                  (Rep (world ('WorldOf (t m))))
+         , MonadTrans t
+         ) => StorageSurgeon t m world
+
+
+------------------------------------------------------------------------------
+-- | Run a monad transformer /underneath/ a 'SystemT'.
+--
+-- Due to the recursive interactions between 'SystemT' and 'QueryT', we're
+-- often unable to put a temporary monad transformer on the top of the stack.
+-- As a result, often 'surgery' is our ony means of introducting ephemeral
+-- effects.
+--
+-- @
+-- draw :: 'SystemT' World IO [Graphics]
+-- draw = fmap fst . 'surgery' runWriterT $
+--   for_ thingsToRender $ \\thingy ->
+--     tell [thingy]
+-- @
+surgery
+    :: ( Monad (t m)
+       , Monad m
+       , StorageSurgeon t m world
+       )
+    => (forall x. t m x -> m (x, b))
+    -> SystemT world (t m) a
+    -> SystemT world m (b, a)
+surgery f m = SystemT $ StateT $ \(i, s) -> do
+  (((i', s'), a), b) <- f $ yieldSystemT (i, hoistStorage s) m
+  pure ((b, a), (i', graftStorage s s'))
 
 
 ------------------------------------------------------------------------------
diff --git a/src/Data/Ecstasy/Internal/Deriving.hs b/src/Data/Ecstasy/Internal/Deriving.hs
--- a/src/Data/Ecstasy/Internal/Deriving.hs
+++ b/src/Data/Ecstasy/Internal/Deriving.hs
@@ -12,6 +12,8 @@
 
 module Data.Ecstasy.Internal.Deriving where
 
+import           Control.Monad.Codensity
+import           Control.Monad.Trans.Class (MonadTrans (..))
 import           Data.Ecstasy.Types (Update (..), VTable (..), Ent (..))
 import           Data.IntMap (IntMap)
 import qualified Data.IntMap as I
@@ -20,6 +22,57 @@
 import           GHC.TypeLits
 
 
+------------------------------------------------------------------------------
+-- | Utility class for implementing 'Data.Ecstasy.Internal.hoistStorage'.
+class GHoistWorld (t :: (* -> *) -> * -> *) (m :: * -> *) a b where
+  gHoistWorld :: a x -> b x
+
+instance {-# OVERLAPPING #-} (MonadTrans t, Functor (t m), Monad m)
+    => GHoistWorld t m (K1 i (VTable m a)) (K1 i' (VTable (t m) a)) where
+  gHoistWorld (K1 (VTable g s)) = K1 $ VTable (fmap lift g) (fmap (fmap lift) s)
+  {-# INLINE gHoistWorld #-}
+
+instance {-# OVERLAPPABLE #-} GHoistWorld t m (K1 i a) (K1 i' a) where
+  gHoistWorld (K1 a) = K1 a
+  {-# INLINE gHoistWorld #-}
+
+instance (Functor (t m), GHoistWorld t m f f')
+    => GHoistWorld t m (M1 i c f) (M1 i' c' f') where
+  gHoistWorld (M1 a) = M1 $ gHoistWorld @t @m a
+  {-# INLINE gHoistWorld #-}
+
+instance (Applicative (t m), GHoistWorld t m a c, GHoistWorld t m b d)
+    => GHoistWorld t m (a :*: b) (c :*: d) where
+  gHoistWorld (a :*: b) = gHoistWorld @t @m a :*: gHoistWorld @t @m b
+  {-# INLINE gHoistWorld #-}
+
+
+------------------------------------------------------------------------------
+-- | Utility class for implementing 'Data.Ecstasy.Internal.graftStorage'.
+class GGraft a b where
+  gGraft :: a x -> b x -> a x
+
+instance {-# OVERLAPPING #-} GGraft (K1 i (VTable m a))
+                                    (K1 i' (VTable (t m) a)) where
+  gGraft a _ = a
+  {-# INLINE gGraft #-}
+
+instance GGraft (K1 i a) (K1 i' a) where
+  gGraft _ (K1 a) = K1 a
+  {-# INLINE gGraft #-}
+
+instance (GGraft f f') => GGraft (M1 i c f) (M1 i' c' f') where
+  gGraft (M1 a) (M1 e) = M1 $ gGraft a e
+  {-# INLINE gGraft #-}
+
+instance (GGraft a c, GGraft b d) => GGraft (a :*: b) (c :*: d) where
+  gGraft (a :*: b) (c :*: d) = gGraft a c :*: gGraft b d
+  {-# INLINE gGraft #-}
+
+
+
+------------------------------------------------------------------------------
+-- | Utility class for implementing 'Data.Ecstasy.Internal.convertSetter'.
 class GConvertSetter a b where
   gConvertSetter :: a x -> b x
 
@@ -36,45 +89,56 @@
   gConvertSetter (K1 Nothing)  = K1 Unset
   {-# INLINE gConvertSetter #-}
 
-instance GConvertSetter f f' => GConvertSetter (M1 i c f) (M1 i' c' f') where
+instance GConvertSetter f f'
+    => GConvertSetter (M1 i c f) (M1 i' c' f') where
   gConvertSetter (M1 a) = M1 $ gConvertSetter a
   {-# INLINE gConvertSetter #-}
 
-instance (GConvertSetter a c , GConvertSetter b d) => GConvertSetter (a :*: b) (c :*: d) where
+instance (GConvertSetter a c, GConvertSetter b d)
+    => GConvertSetter (a :*: b) (c :*: d) where
   gConvertSetter (a :*: b) = gConvertSetter a :*: gConvertSetter b
   {-# INLINE gConvertSetter #-}
 
 
+------------------------------------------------------------------------------
+-- | Utility class for implementing 'Data.Ecstasy.Internal.getEntity'.
 class GGetEntity m a b where
-  gGetEntity :: a x -> Int -> m (b x)
+  gGetEntity :: a x -> Int -> Codensity m (b x)
 
-instance (Applicative m)
-      => GGetEntity m (K1 i (VTable m a)) (K1 i' (Maybe a)) where
-  gGetEntity (K1 (VTable vget _)) e = fmap K1 $ vget $ Ent e
+instance (Monad m)
+    => GGetEntity m (K1 i (VTable m a)) (K1 i' (Maybe a)) where
+  gGetEntity (K1 (VTable vget _)) e = lift $ fmap K1 $ vget $ Ent e
   {-# INLINE gGetEntity #-}
 
-instance Applicative m => GGetEntity m (K1 i (IntMap a)) (K1 i' (Maybe a)) where
+instance Applicative m
+    => GGetEntity m (K1 i (IntMap a)) (K1 i' (Maybe a)) where
   gGetEntity (K1 a) e = pure . K1 $ I.lookup e $ a
   {-# INLINE gGetEntity #-}
 
-instance Applicative m => GGetEntity m (K1 i (Maybe (Int, a))) (K1 i' (Maybe a)) where
+instance Applicative m
+    => GGetEntity m (K1 i (Maybe (Int, a))) (K1 i' (Maybe a)) where
   gGetEntity (K1 (Just (e', a))) e | e == e' = pure . K1 $ Just a
   gGetEntity _ _ = pure $ K1 Nothing
   {-# INLINE gGetEntity #-}
 
-instance (Functor m, GGetEntity m f f') => GGetEntity m (M1 i c f) (M1 i' c' f') where
+instance (Functor m, GGetEntity m f f')
+    => GGetEntity m (M1 i c f) (M1 i' c' f') where
   gGetEntity (M1 a) e = fmap M1 $ gGetEntity a e
   {-# INLINE gGetEntity #-}
 
-instance (Applicative m, GGetEntity m a c , GGetEntity m b d) => GGetEntity m (a :*: b) (c :*: d) where
+instance (Applicative m, GGetEntity m a c, GGetEntity m b d)
+    => GGetEntity m (a :*: b) (c :*: d) where
   gGetEntity (a :*: b) e = (:*:) <$> gGetEntity a e <*> gGetEntity b e
   {-# INLINE gGetEntity #-}
 
 
+------------------------------------------------------------------------------
+-- | Utility class for implementing 'Data.Ecstasy.Internal.setEntity'.
 class GSetEntity m a b where
-  gSetEntity :: a x -> Int -> b x -> m (b x)
+  gSetEntity :: a x -> Int -> b x -> Codensity m (b x)
 
-instance Applicative m => GSetEntity m (K1 i (Update a)) (K1 i' (Maybe (Int, a))) where
+instance Applicative m
+    => GSetEntity m (K1 i (Update a)) (K1 i' (Maybe (Int, a))) where
   gSetEntity (K1 (Set a)) e _ = pure . K1 $ Just (e, a)
   gSetEntity (K1 Unset) e (K1 (Just (e', b))) =
     pure $ if e == e'
@@ -83,24 +147,28 @@
   gSetEntity _  _ (K1 b) = pure $ K1 b
   {-# INLINE gSetEntity #-}
 
-instance (Applicative m)
-      => GSetEntity m (K1 i (Update a)) (K1 i' (VTable m a)) where
+instance (Monad m)
+    => GSetEntity m (K1 i (Update a)) (K1 i' (VTable m a)) where
   gSetEntity (K1 a) e (K1 z@(VTable _ vset)) =
-    vset (Ent e) a *> pure (K1 z)
+    lift (vset (Ent e) a) *> pure (K1 z)
   {-# INLINE gSetEntity #-}
 
-instance Applicative m => GSetEntity m (K1 i (Update a)) (K1 i' (IntMap a)) where
+instance Applicative m
+    => GSetEntity m (K1 i (Update a)) (K1 i' (IntMap a)) where
   gSetEntity (K1 Keep) _ (K1 b) = pure $ K1 b
   gSetEntity (K1 (Set a)) e (K1 b) = pure . K1 $ I.alter (const $ Just a) e b
   gSetEntity (K1 Unset) e (K1 b) = pure . K1 $ I.alter (const Nothing) e b
   {-# INLINE gSetEntity #-}
 
-instance (Functor m, GSetEntity m f f') => GSetEntity m (M1 i c f) (M1 i' c' f') where
+instance (Functor m, GSetEntity m f f')
+    => GSetEntity m (M1 i c f) (M1 i' c' f') where
   gSetEntity (M1 a) e (M1 b) = fmap M1 $ gSetEntity a e b
   {-# INLINE gSetEntity #-}
 
-instance (Applicative m, GSetEntity m a c, GSetEntity m b d) => GSetEntity m (a :*: b) (c :*: d) where
-  gSetEntity (a :*: b) e (c :*: d) = (:*:) <$> gSetEntity a e c <*> gSetEntity b e d
+instance (Applicative m, GSetEntity m a c, GSetEntity m b d)
+    => GSetEntity m (a :*: b) (c :*: d) where
+  gSetEntity (a :*: b) e (c :*: d) = (:*:) <$> gSetEntity a e c
+                                           <*> gSetEntity b e d
   {-# INLINE gSetEntity #-}
 
 
@@ -109,6 +177,10 @@
 {-# INLINE def #-}
 
 
+------------------------------------------------------------------------------
+-- | Utility class for implementing various defaults. The 'keep' parameter is
+-- used to statically describe whether or not to keep the previous value when
+-- dealing with 'Update' fields.
 class GDefault (keep :: Bool) f where
   gdef :: f a
 
@@ -133,7 +205,8 @@
   {-# INLINE gdef #-}
 
 instance {-# OVERLAPPING #-} (Applicative m, KnownSymbol sym)
-      => GDefault keep (M1 S ('MetaSel ('Just sym) x y z) (K1 i (VTable m a))) where
+    => GDefault keep (M1 S ('MetaSel ('Just sym) x y z)
+                     (K1 i (VTable m a))) where
   gdef = M1 $ K1 $ VTable (const err) (const $ const err)
     where
       err :: err
@@ -148,7 +221,8 @@
   gdef = M1 $ gdef @keep
   {-# INLINE gdef #-}
 
-instance (GDefault keep a, GDefault keep b) => GDefault keep (a :*: b) where
+instance (GDefault keep a, GDefault keep b)
+    => GDefault keep (a :*: b) where
   gdef = gdef @keep :*: gdef @keep
   {-# INLINE gdef #-}