Monadic capabilities using vinyl.

vinyl-capability.hs

{-# language FunctionalDependencies #-}
{-# language KindSignatures #-}
{-# language DerivingVia #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
-- some extensions elided, GHC should tell you what they are
module Capability where

import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Class
import Data.Vinyl
import UnliftIO

-- * Core definitions
newtype Cap (m :: Type -> Type) k = Cap { unCap :: k m }

type Caps m = Rec (Cap m)
-- might want to switch to ARec if you expect to have a lot of capabilities

type (∈!) (k :: (Type -> Type) -> Type) ks = RElem k ks

class Monad m => MonadCapability ks m | m -> ks where
  getCaps :: m (Caps m ks)
  default getCaps :: (MonadCapability n, MonadTrans t, Monad (t n), t n ~ m) => m (Caps m ks)
  getCaps = lift getCaps

newtype CapabilityT ks m a = CapabilityT { runCapabilityT :: Caps (CapabilityT ks m a) ks -> m a }
  deriving via (ReaderT (Caps (CapabilityT ks m a) ks) m a)
    (Functor, Applicative, Monad, MonadState, MonadIO, MonadUnliftIO)
    -- this should ideally contain *all* the mtl classes, I'm just lazy

instance Monad m => MonadCapability ks (CapabilityT ks m) where
  getCaps = CapabilityT pure

instance MonadCapability m => MonadCapability (ReaderT e m)
instance MonadCapability m => MonadCapability (StateT s m)
-- repeat for every monad transformer available

-- * Some combinators
getCap :: forall k ks m. (k ∈! ks, MonadCapability ks m) => m (k m)
getCap = unCap . rget @k <$> getCaps

withCap :: forall k ks m a. (k ∈! ks, MonadCapability ks m) => (k m -> m a) -> m a
withCap sel = getCap >>= sel

withCap1 :: forall k ks m a b. (k ∈! ks, MonadCapability ks m) => (k m -> a -> m b) -> a -> m b
withCap1 sel a = do cap <- getCap; sel cap a

withCap2 :: forall k ks m a b c. (k ∈! ks, MonadCapability ks m) => (k m -> a -> b -> m c) -> a -> b -> m c
withCap2 sek a b = do cap <- getCap; sel cap a b

-- can be trivially extended for higher-arity functions

-- * An example

data Terminal m = Terminal { terminalPutStr :: String -> m () }

putStr :: (Terminal ∈! ks, MonadCapability ks m) => String -> m ()
putStr = withCap1 terminalPutStr