polysemy-research / polysemy-zoo

:monkey::panda_face: Experimental, user-contributed effects and interpreters for polysemy
BSD 3-Clause "New" or "Revised" License
70 stars 20 forks source link

MonadMask constraint absorber. #61

Open KingoftheHomeless opened 4 years ago

KingoftheHomeless commented 4 years ago

A MonadMask constraint absorber with the following type signature:

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

Should be possible by lifting uninterruptible/Mask à la https://github.com/polysemy-research/polysemy/issues/135#issuecomment-530367719 and lifting generalBracket through the following:

generalBracket
  :: Member (Final IO) r
  => Sem r a
  -> (a -> ExitCase b -> Sem r c)
  -> (a -> Sem r b)
  -> Sem r (b, c)
generalBracket alloc dealloc use = withStrategicToFinal $ do
  alloc'   <- runS alloc
  dSuccess <- bindS (\(a, b) -> (b ,) <$> dealloc a (ExitCaseSuccess b))
  dFailure <- bindS (uncurry dealloc)
  use'     <- bindS (\a -> (,) a <$> use a)
  ins      <- getInspectorS
  pure $ X.mask $ \restore -> do
    res <- alloc'
    fb   <- restore (use' res) `X.catch` \e -> do
      _ <- dFailure $ (, ExitCaseException e) <$> res
      X.throwIO e
    if isJust (inspect ins fb) then
      dSuccess fb
    else do
      _ <- dFailure $ (, ExitCaseAbort) <$> res
      return ((\(_,_) -> bomb "generalBracket") <$> fb)

bomb :: String -> a
bomb str = error $
    str ++ ": Uninspectable effectful state still carries a visible result.\
            \ You're probably using an interpreter\
            \ that uses 'weave' improperly.\
            \ See documentation for more information."
KingoftheHomeless commented 4 years ago

If we figure out https://github.com/polysemy-research/polysemy/issues/304, and implement the Mask effect described there, we can also do:

absorbMask
    :: Member (Mask s) r
    => (MonadMask (Sem r) => Sem r a)
    -> Sem r a