Constraint absorber - Polysemy

Welcome to the Functional Programming Zulip Chat Archive. You can join the chat here.


Was tinkering with possibility of making even simpler version of absorber interface:

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

  :: 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"
Georgi Lyubenov // googleson78

hm, but if we live in the unreal ideal world where everything gets inlined away, doesn't the unsafeCoerce get in the way of ghc?

Georgi Lyubenov // googleson78

or does the existing one also use unsafeCoerce?

Georgi Lyubenov // googleson78

also, is this simpler for usage/creating user "absorb" functions? not too familiar with the other one


It does - as it does in current version in zoo

Georgi Lyubenov // googleson78

oh yeah, cause reflection itself also does


The other one uses custom "dictionaries" and wrapping newtypes for every class - I don't think it makes much sense, because the former isn't that different from writing instance that interprets directly into some special-purpose effect, while the latter seems to only exist to safely allow passing the former into instance using reflection


I will investigate possibility of using magicDict, which is compile-time only and replaced using builtin rule



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

  :: 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

Haven't tested it thoughtfully yet, but it seems to work

Georgi Lyubenov // googleson78

the only thing left now is for NonDet to behave :P