Constraint absorber - Polysemy

import qualified Control.Monad.Reader as R
import Data.Coerce
import Data.Kind
import Polysemy
import Polysemy.Reader
import Unsafe.Coerce

-------------------------------------------------------------------------------
newtype Absorber :: forall k. k -> EffectRow -> Type -> Type where
  Absorber :: Sem r a -> Absorber i r a
  deriving newtype (Functor, Applicative, Monad)

type Absorption p i r a = p (Absorber i r) => (p (Sem r) => Sem r a) -> Sem r a

absorb :: forall p i r a. Absorption p i r a
absorb ma = unsafeCoerceConstraint @(p (Sem r)) @(p (Absorber i r)) ma

-------------------------------------------------------------------------------
unsafeCoerceConstraint :: forall p q a. (p => a) -> q => a
unsafeCoerceConstraint a = unsafeCoerce @_ @(q => a) (Wants @p @a a)

newtype c :=> a = Wants (c => a)

-------------------------------------------------------------------------------
instance Member (Reader i) r => R.MonadReader i (Absorber i r) where
  ask     = Absorber ask
  local f = Absorber . local f . coerce

absorbReader
  :: forall i r a. Member (Reader i) r => Absorption (R.MonadReader i) i r a
absorbReader = absorb @(R.MonadReader i) @i

-------------------------------------------------------------------------------
test :: String
test = run $ runReader "a" $ absorbReader $ fmap concat $
  sequence [R.ask, R.local (const "b") R.ask, R.asks (++ "b")]

-- $> test
-- "abab"

instance (Members '[Final m, NonDet] r, MonadParsec e s m)
      => MonadParsec e s (Absorber (e, s, m _0) r) where
  parseError = Abs . embedFinal . parseError
  label l (Abs ma) = Abs $ withStrategicToFinal $ label l <$> runS ma
  try (Abs ma) = Abs $ withStrategicToFinal $ try <$> runS ma
  lookAhead (Abs ma) =
    Abs $ withStrategicToFinal $ lookAhead <$> runS ma
  notFollowedBy (Abs ma) = Abs $ withStrategicToFinal $
    liftA2 (<$) getInitialStateS $ notFollowedBy <$> runS ma
  withRecovery f (Abs ma) = Abs $ withStrategicToFinal do
    s  <- getInitialStateS
    f' <- bindS $ un Abs <$> f
    withRecovery (f' . (s $>)) <$> runS ma
  observing (Abs ma) = Abs $ withStrategicToFinal do
    s <- getInitialStateS
    (fmap . fmap) (either ((s $>) . Left) (fmap Right)) $ observing <$> runS ma
  eof = Abs $ embedFinal eof
  token f = Abs . embedFinal . token f
  tokens f = Abs . embedFinal . tokens f
  takeWhileP f = Abs . embedFinal . takeWhileP f
  takeWhile1P f = Abs . embedFinal . takeWhile1P f
  takeP f = Abs . embedFinal . takeP f
  getParserState = Abs $ embedFinal getParserState
  updateParserState = Abs . embedFinal . updateParserState

absorbParsec
  :: forall e s m r a
   . ( Member (Final m) r
     , MonadParsec e s m
     , MonadParsec e s (Absorber (e, s, m ()) (NonDet:r))
     )
  => (MonadParsec e s (Sem (NonDet:r)) => Sem (NonDet:r) a) -> Sem r a
absorbParsec ma = interpretFinal (\case
    Empty      -> pure empty
    Choose l r -> (<|>) <$> runS l <*> runS r
  ) $ absorb @(MonadParsec e s) @(e, s, m ()) ma