AnyMonad.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
module AnyMonad where

import Data.Kind
import Control.Applicative

newtype AnyMonad c a = AnyMonad (forall m . c m => m a)

type Implies1 :: (k -> Constraint) -> (k -> Constraint) -> Constraint
type Implies1 c1 c2 = forall x . c1 x => c2 x

instance (Implies1 c Functor) => Functor (AnyMonad c) where
  f `fmap` (AnyMonad x) = AnyMonad $ f <$> x
  x <$ (AnyMonad y) = AnyMonad $ x <$ y

instance (Implies1 c Applicative) => Applicative (AnyMonad c) where
  pure a = AnyMonad $ pure a
  (AnyMonad f) <*> (AnyMonad x) = AnyMonad $ f <*> x
  liftA2 f (AnyMonad x) (AnyMonad y) = AnyMonad $ liftA2 f x y
  (AnyMonad x) *> (AnyMonad y) = AnyMonad $ x *> y
  (AnyMonad x) <* (AnyMonad y) = AnyMonad $ x <* y

instance (Implies1 c Monad) => Monad (AnyMonad c) where
  (AnyMonad x) >>= f = AnyMonad $ do
    x' <- x
    let AnyMonad res = f x'
    res
  (>>) = (*>)
  return = pure

class (Monad m) => Foo m where
  doFoo :: m ()

newtype AnyFoo a = AnyFoo (forall m . Foo m => m a)
  deriving Functor via (AnyMonad Foo)
  deriving Applicative via (AnyMonad Foo)
  deriving Monad via (AnyMonad Foo)

instance Foo AnyFoo where
  doFoo = AnyFoo $ doFoo