Experimentation with Lift' on ContT

Lift'Experimentation.hs

runReaderInMonadReader :: (Member (Lift' m) r, MonadReader i m)
                       => Sem (Reader i ': r) a
                       -> Sem r a
runReaderInMonadReader (Sem sem) = sem $ \u -> case decomp u of
  Right (Yo e s wv ex _) -> case e of
    Ask -> ex . (<$ s) <$> sendM' Control.Monad.Reader.ask
    Local f m -> fmap ex $ withWeaving $ \s' wv' _ ->
      Control.Monad.Reader.local
        f
        (wv' ( runReaderInMonadReader (wv (m <$ s)) <$ s'))
  Left g -> liftSem $ hoist runReaderInMonadReader g

-- Way too janky. Plays badly with MonadState's that can fail.
runWriterInMonadState :: (Monoid s, Member (Lift' m) r, MonadState s m)
                      => Sem (Writer s ': r) a
                      -> Sem r a
runWriterInMonadState = interpretH $ \case
  Tell o   -> do
    a <- sendM' $ Control.Monad.State.modify (<> o)
    pureT a
  Listen m -> do
    s <- sendM' $ Control.Monad.State.state (\s -> (s, mempty))
    m' <- runT m
    res <- raise $ runWriterInMonadState m'
    s' <- sendM' $ Control.Monad.State.state (\s' -> (s', s <> s'))
    return ((,) s' <$> res)
  Censor f m -> do
    s <- sendM' $ Control.Monad.State.state (\s -> (s, mempty))
    m' <- runT m
    res <- raise $ runWriterInMonadState m'
    sendM' $ Control.Monad.State.modify (\s' -> s <> f s')
    return res

callCC' :: Member (Lift' (ContT s m)) r
        => ((forall b. a -> Sem r b) -> Sem r a)
        -> Sem r a
callCC' cc = withWeaving $ \s wv _ ->
  ContT $ \c ->
    runContT
      (wv $
        cc (\a -> sendM' . ContT $ \_ -> c (a <$ s))
        <$ s)
    c

shift' :: (Monad m, Member (Lift' (ContT (Maybe s) m)) r)
       => ((a -> Sem r (Maybe s)) -> Sem r (Maybe s))
       -> Sem r a
shift' cc = withWeaving $ \s wv ins ->
  ContT $ \c ->
    runContT
      (wv $
        cc (\a -> sendM' . ContT $ \c' -> c (a <$ s) >>= c')
        <$ s)
      (pure . join . ins)

test1 :: IO (Int, String)
test1 =
    (`runStateT` mempty)
  . (`runReaderT` 1)
  . (`runContT` pure)
  . runM'
  . runWriterInMonadState
  . runReaderInMonadReader $ do
   tell "abra
   callCC' $ \c ->
     local (+1) $ censor (\_ -> "") (c ())
   i <- ask
   tell "hadabra"
   return i

-- test1 == (2, "hadabra")
-- This is runWriterInMonadState's fault, not callCC'.

test2 :: IO (Maybe Int, String)
test2 =
    (`runStateT` mempty)
  . (`runReaderT` 1)
  . (`runContT` pure)
  . runM'
  . runWriterInMonadState
  . runReaderInMonadReader $ do
   tell "abra"
   shift' $ \c ->
     local (+1) $ censor (\_ -> "") (c ())
   i <- ask
   tell "hadabra"
   return (Just i)
-- test2 == (Just 2, "abra")