Extensible effects in Haskell

Roman Cheplyaka
@shebang

Impure

sqlConn = MySQLdb.connect(..)
mqConn = pika.BlockingConnection(..)

def foo():
  cur = sqlConn.cursor()
  chan = mqConn.channel()
  ...

Parameter passing

foo
  :: SQL.Connection
  -> MQ.Connection
  -> IO ()
foo sqlConn mqConn = do
  ...
  x <- query sqlConn ...
  sendMsg mqConn ...
  ...

Reader monad

type Conns = (SQL.Connection, MQ.Connection)

foo :: ReaderT Conns IO ()
foo = do
  ...
  (sqlConn, mqConn) <- ask
  x <- query sqlConn ...
  sendMsg mqConn ...
  ...

Running Reader monad

main = do
  sqlConn <- SQL.connect ...
  mqConn <- MQ.connect ...
  runReaderT foo (sqlConn, mqConn)

Reader monad

bar :: SQL.Connection -> IO ()
bar sqlConn = do
  ...

Reader monad

bar :: ReaderT SQL.Connection IO ()
bar sqlConn = do
  ...

This won't work:

baz = do
  foo -- has type ReaderT Conns IO ()
  bar -- has type ReaderT SQL.Connection IO ()

Class-based approach

foo :: (MonadReader SQL.Connection,
        MonadReader MQ.Connection)
    => m ()

bar :: MonadReader SQL.Connection => m ()

Now this should work:

baz = do
  foo
  bar

(Except it doesn't.)

Fun dep

class MonadReader e m | m -> e where
    ask :: m e

No fun dep

instance MonadReader e (ReaderT e m) where

instance
  MonadReader e m =>
  MonadReader e (ReaderT e' m) where

Extensible effects

foo :: (Member (Reader SQL.Connection u),
        Member (Reader MQ.Connection u))
    => Eff u ()

Is very slow!

MonadReader needs your help

data Nat = Zero | Suc Nat

class MonadReaderN (n :: Nat) r m where
  askN :: Proxy n -> m r

instance MonadReaderN Zero e (ReaderT e m) where
  askN _ = ask

instance (MonadTrans t,
          MonadReaderN n r m)
       => MonadReaderN (Suc n) r (t m)
  where
    askN _ = lift $ askN (Proxy :: Proxy n)

Closed type families

type family
  Find
    (t :: (* -> *) -> (* -> *))
    (m :: * -> *)
    :: Nat where
  Find t (t m) = Zero
  Find t (p m) = Suc (Find t m)

type MonadReader r m =
  MonadReaderN (Find (ReaderT r) m) r m

ask :: forall r m. MonadReader r m => m r
ask = askN (Proxy :: Proxy (Find (ReaderT r) m))

Effectful transformers

type family
  CanDo
    (t :: (* -> *))
    (eff :: k)
    :: Bool

data EffState s
data EffReader e
data EffWriter w

Effectful transformers

type instance CanDo (ReaderT e m) eff =
  ReaderCanDo e eff

type family ReaderCanDo s eff where
  ReaderCanDo s (EffReader s) = True
  ReaderCanDo s eff = False

Effectful transformers

type family
  MapCanDo
    (x :: k)
    (m :: * -> *)
    :: [Bool] where
  MapCanDo eff (t m) =
    (CanDo (t m) eff) : MapCanDo eff m
  MapCanDo eff m = [CanDo eff m]

Effectful transformers

type family FindTrue
  (bs :: [Bool])
  :: Nat
  where
  FindTrue (True : t) = Zero
  FindTrue (False : t) = Suc (FindTrue t)

type Find eff (m :: * -> *) =
  FindTrue (MapCanDo eff m)

State vs Reader

foo :: (MonadState User m, ...) => m ()

bar :: (MonadReader User m, ...) => m ()

baz = do
  foo
  bar

State as Reader

type instance CanDo (StateT s m) eff = StateCanDo s eff

type family StateCanDo s eff where
  StateCanDo s (EffState s) = True
  StateCanDo s (EffReader s) = True
  StateCanDo s eff = False

instance MonadReaderN Zero r (StateT r m) where
    askN _ = get

Zooming

foo :: (MonadState Age m, ...) => m ()

bar :: (MonadState User m, ...) => m ()

data User = User
  { userAge :: Age
  , ...
  }

ageL :: Lens User Age

Zooming

withAge :: MonadState User m => StateT Age m a -> m a
withAge action = do
  user <- get
  (result, age') <- runStateT action (getL ageL user)
  put $ setL ageL age' user
  return result

Zooming

newtype AgeT m a = AgeT (m a)

type instance CanDo (AgeT m) eff =
  AgeCanDo s eff

type family AgeCanDo s eff where
  AgeCanDo s (EffState Age) = True
  AgeCanDo s eff = False

instance MonadState User m =>
  MonadStateN Zero Age (AgeT m) where
  get _ = gets $ getL ageL
  put _ = modify . setL ageL

Zooming

class Has rec fld where
  hasLens :: Lens rec fld

newtype ZoomT rec fld m a = ZoomT (m a)
type instance CanDo (ZoomT m) eff =
  ZoomCanDo s eff
type family ZoomCanDo rec fld s eff where
  ZoomCanDo s (EffState fld) = True
  ZoomCanDo s eff = False
instance MonadState rec m =>
  MonadStateN Zero fld (ZoomT rec fld m) where
  get _ = gets $ getL (hasLens :: Lens rec fld)
  put _ = modify . setL (hasLens :: Lens rec fld)