File that accompanies my blog post about unliftio-core

askUnliftIO.hs

#!/usr/bin/env stack
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-
    stack
    script
    --resolver lts-13.16
    --package transformers
-}
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Reader (ReaderT (..))

test :: (String -> IO ()) -> IO ()
test f = f "test"

test2 :: (String -> ReaderT env IO ()) -> ReaderT env IO ()
test2 f =
  askUnliftIO
   >>= \wrappedUnliftedThing ->
    let unwrapped = unwrap wrappedUnliftedThing
     in liftIO $ test (unwrapped . f)
  where
    unwrap :: UnliftIO m -> m a -> IO a
    unwrap = unliftIO

myPrint :: String -> ReaderT String IO ()
myPrint string = ReaderT $ \env -> print $ env ++ " " ++ string

main :: IO ()
main = runReaderT (test2 myPrint) "Environment"

instance MonadUnliftIO IO where
  askUnliftIO = return (UnliftIO id)

instance MonadUnliftIO m => MonadUnliftIO (ReaderT r m) where
  askUnliftIO =
    ReaderT $ \env ->
      askUnliftIO >>= \unliftedIO
       -> liftIO $
          return (UnliftIO (unliftIO unliftedIO . flip runReaderT env))

newtype UnliftIO m = UnliftIO
  { unliftIO :: forall a. m a -> IO a
  }

class MonadIO m =>
      MonadUnliftIO m
  where
  askUnliftIO :: m (UnliftIO m)