Invoke callback that has MonadMask constraint

2020-01-02 11:45:37

I have the following function - processStream.

processStream :: Members '[Embed IO,
                          Output LogMessage,
                          NonDet,
                          Reader CommCentre,
                          State StreamingState,
                          LoginHandler,
                          Error String] r
              => Context
              -- ^ Tcp connection context
              -> Sem r ()

I need to call processStream from a callback below ((T.Context, S.SockAddr) -> m r), but unfortunately it has MonadMask constraint.
This is connect from Network.Simple.TCP.TLS package:

connect
  :: (MonadIO m, E.MonadMask m)
  => T.ClientParams
  -> S.HostName
  -> S.ServiceName
  -> ((T.Context, S.SockAddr) -> m r)
  -> m r

Current problem:

connectAndAuthenticate :: Members '[Embed IO,
                                   Output LogMessage,
                                   NonDet,
                                   Reader CommCentre,
                                   State StreamingState,
                                   LoginHandler,
                                   Error String] r
                       => String
                       -> Int
                       -> Sem r ()
connectAndAuthenticate hostName port = do
    logDebug $ mconcat ["connectAndAuthenticate ["
                       , T.pack hostName
                       , ":"
                       , T.pack . show $ port
                       , "] - staring"

    params <- liftIO $ newDefaultClientParams (hostName, B.empty)
    -- The commented part below does not compile:
{-
     • Could not deduce (Control.Monad.Catch.MonadMask (Sem r))
        arising from a use of ‘connect’
      from the context: Members
                          '[Embed IO, Output LogMessage, NonDet, Reader CommCentre,
                            State StreamingState, LoginHandler, Error String]
                          r
        bound by the type signature for:
                   connectAndAuthenticate :: forall (r :: [(* -> *) -> * -> *]).
                                             Members
                                               '[Embed IO, Output LogMessage, NonDet,
                                                 Reader CommCentre, State StreamingState,
                                                 LoginHandler, Error String]
                                               r =>
                                             String -> Int -> Sem r ()
        at src/BfHaskell/StreamingAPI/StreamingProcessor.hs:(236,1)-(245,34)
    • In the expression: connect params hostName (show port)
      In a stmt of a 'do' block:
        connect params hostName (show port)
          $ \ (ctx, _saddr) -> do processStream ctx
      In the expression:
        do logDebug
             $ mconcat ["connectAndAuthenticate [", T.pack hostName, ....]
           params <- liftIO $ newDefaultClientParams (hostName, B.empty)
           connect params hostName (show port) $ \ (ctx, _saddr) -> do ...
           logDebug "connectAndAuthenticate - finished"
    |
260 |     connect params hostName (show port) $ \(ctx, _saddr) -> do
    |     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-}

    {-
    connect params hostName (show port) $ \(ctx, _saddr) -> do
        processStream ctx
    -}

    logDebug "connectAndAuthenticate - finished"

What are possible solutions?
I had a look at poysemy-zoo and it has Polysemy.ConstraintAbsorber, but I could not figure out if it is possible to wrap MonadMask using it?

TheMatten

2020-01-02 12:22:08

@Martins @Love Waern (King of the Homeless) may have more insight on this problem, but I'm worried that in general, arbitrary Sem can't have valid MonadMask instance
Quick and dirty solution would be wrapping your Sem argument in a newtype that implements MonadMask through Member (Embed IO)

Martins

2020-01-02 12:44:45

@TheMatten
Thank you for insight! I am afraid you might be right, because MonadMask has mask, which deals with async exception masking, and it might not be compatible with Polysemy design.

Do you think @Love Waern (King of the Homeless) shall read this forum or I should contact him in a different way?

TheMatten

2020-01-02 12:46:08

I think he should get a notification anyway

Martins

2020-01-02 12:47:06

Thanks!

Love Waern (King of the Homeless)

2020-01-02 13:01:36

I'm here. Funnily enough, what prevents Sem to have MonadMask is not mask, but rather, generalBracket.

Love Waern (King of the Homeless)

2020-01-02 13:03:04

mask is implementable through the following effect:

import qualified Control.Exception as X

data Mask s m a where
  Mask' :: (s -> m a) -> Mask s m a
  Restore' :: s -> m a -> Mask s m a

mask
  :: Member (Mask s) r
  => ((forall x. Sem r x -> Sem r x) -> Sem r a)
  -> Sem r a
mask main = send $ Mask' $ \s -> main (\m -> send (Restore' s m))

newtype Restoration = Restoration (forall x. IO x -> IO x)

runMask
  :: Member (Final IO) r
  => Sem (Mask Restoration ': r) a
  -> Sem r a
runMask = interpretFinal $ \case
  Restore' (Restoration restore) m ->  do
    m' <- runS m
    pure $ restore m'
  Mask' main -> do
    main' <- bindS main
    s <- getInitialStateS
    pure $ X.mask $ \restore -> main' (Restoration restore <$ s)

Martins

2020-01-02 13:10:05

@Love Waern (King of the Homeless) Thank you!

Love Waern (King of the Homeless)

2020-01-02 13:10:25

Let me take another look to see what can be done about generalBracket.

Love Waern (King of the Homeless)

2020-01-02 14:34:01

Ok, so, to address this, it's possible for us to do one of three things:

MakeMask be based upon the un/block primitives, rather than the MonadMask primitives:

data Mask m a where
  Unblock              :: m a -> Mask m a
  Block                :: m a -> Mask m a
  BlockUninterruptible :: m a -> Mask m a
  GetMaskingState      ::        Mask m MaskingState

Upsides:
- No type variable.
Downsides:
- Inflexible. Doesn't support

maskToFinal :: (Member (Final m) r, MonadMask m)  => Sem (Mask ': r) a -> Sem r a

Make a constraint absorber that is based uponFinal IO rather than a Mask effect:

absorbMask
    :: Member (Final IO) r
    => (MonadMask (Sem r) => Sem r a)
    -> Sem r a

Upsides:
- Doesn't require a Mask effect

Downsides:
- Restricted to IO, rather than arbitrary MonadMask.

Change internals of Polysemy to make interpreting generalBracket possible. This enables the following:

data Mask s m a where
  Mask' :: (s -> m a) -> Mask s m a
  UninterruptibleMask' :: (s -> m a) -> Mask s m a
  Restore' :: s -> m a -> Mask s m a
  GeneralBracket ::
       m a
    -> (a -> ExitCase b -> m c)
    -> (a -> m b)
    -> Mask s m (b, c)

newtype Restoration m = Restoration (forall x. m x -> m x)

maskToFinal
  :: (Member (Final m) r, MonadMask m)
  => Sem (Mask (Restoration m) ': r) a
  -> Sem r a

Upsides:
- A Mask effect that covers exactly the power of MonadMask
- Support for a proper maskToFinal interpreter.

Downsides:
- Change to internals is non-trivial.
- maskToFinal has some wonky semantics in the interplay with effectful state from other effects.

My thoughts are that we implement 2. and add it to polysemy-zoo, but also look at implementing the change to the internals that enables 3., and then wait and see if we want to implement a Mask effect based upon it. I'll create issues about this in each respective repo.

Martins

2020-01-02 14:35:56

Wow! I am amazed! :)

Love Waern (King of the Homeless)

2020-01-02 15:55:57

Issues created:
https://github.com/polysemy-research/polysemy-zoo/issues/61
https://github.com/polysemy-research/polysemy/issues/304

MonadMask constraint absorber. · Issue #61 · polysemy-research/polysemy-zoo

A MonadMask constraint absorber with the following type signature: absorbMask :: Member (Final IO) r => (MonadMask (Sem r) => Sem r a) -> Sem r a Should be possible by lifting uninterrupti...

Restrict the existentially quantified monad in a `Weaving` to be `Sem r` · Issue #304 · polysemy-research/polysemy

From the documentation for Weaving in Polysemy.Internal.Union: data Weaving e m a where Weaving :: Functor f => { weaveEffect :: e m a -- ^ The original effect GADT originally lifted via -- &#39...

Invoke callback that has MonadMask constraint - Polysemy