Skip to content

Instantly share code, notes, and snippets.

@nicolashery

nicolashery/AsyncMonadBaseControlExample.hs

Created September 9, 2022 14:01
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save nicolashery/ce5d627090553d8615d61f607078e778 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save nicolashery/ce5d627090553d8615d61f607078e778 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. nicolashery created this gist Sep 9, 2022.
    36 changes: 36 additions & 0 deletions AsyncMonadBaseControlExample.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,36 @@
    module AsyncMonadBaseControlExample where

    import Blammo.Logging (LoggingT)
    import Control.Concurrent.Async.Lifted.Safe (concurrently)
    import Control.Monad.Base (MonadBase)
    import Control.Monad.Reader (MonadIO, MonadReader, MonadTrans (lift), ReaderT)
    import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith, restoreM), StM)
    import Data.Text.Lazy qualified as TL
    import Web.Scotty.Trans (ActionT, text)

    data AppEnv = AppEnv

    newtype App a = App
    { unApp :: ReaderT AppEnv (LoggingT IO) a
    }
    deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppEnv, MonadBase IO)

    -- Instance copied from:
    -- https://stackoverflow.com/questions/28137838/creating-monadbasecontrol-instance-for-newtype
    instance MonadBaseControl IO App where
    type StM App a = a
    liftBaseWith f = App $ liftBaseWith $ \runInBase -> f (runInBase . unApp)
    restoreM = App . restoreM

    executeTaskA :: App TL.Text
    executeTaskA = undefined

    executeTaskB :: App TL.Text
    executeTaskB = undefined

    exampleHandler :: ActionT TL.Text App ()
    exampleHandler = do
    -- ...
    (resultA, resultB) <- lift $ concurrently executeTaskA executeTaskB
    -- ...
    text $ mconcat [resultA, "\n", resultB]
    28 changes: 28 additions & 0 deletions AsyncMonadUnliftIOExample.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,28 @@
    module AsyncMonadUnliftIOExample where

    import Blammo.Logging (LoggingT)
    import Control.Monad.Reader (MonadIO, MonadReader, MonadTrans (lift), ReaderT)
    import Data.Text.Lazy qualified as TL
    import UnliftIO (MonadUnliftIO)
    import UnliftIO.Async (concurrently)
    import Web.Scotty.Trans (ActionT, text)

    data AppEnv = AppEnv

    newtype App a = App
    { unApp :: ReaderT AppEnv (LoggingT IO) a
    }
    deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppEnv, MonadUnliftIO)

    executeTaskA :: App TL.Text
    executeTaskA = undefined

    executeTaskB :: App TL.Text
    executeTaskB = undefined

    exampleHandler :: ActionT TL.Text App ()
    exampleHandler = do
    -- ...
    (resultA, resultB) <- lift $ concurrently executeTaskA executeTaskB
    -- ...
    text $ mconcat [resultA, "\n", resultB]