First class instances - Haskell

type f ~> g = forall x. f x -> g x

data f ~⋅~> g = MMorph
  { convert :: Inst (Monad f) -> Inst (Monad g)
  , nat :: f ~> g
  }

mapTeletype :: (f ~⋅~> g) -> Inst (Teletype f) -> Inst (Teletype g)
mapTeletype (MMorph { convert, nat }) (Teletype m r w) = Teletype (convert m) (nat r) (nat . w)

ezmonad :: forall m. (forall a b. m a -> (a -> m b) -> m b) -> (forall a. a -> m a) -> Inst (Monad m)
ezmonad (>>=) pure = Monad applicative (>>=) (*>) pure error
  where
  (<$>) :: (a -> b) -> m a -> m b
  (<$>) f ma = ma >>= (pure . f)

  ($>) :: b -> m a -> m b
  ($>) = (<$>) . const

  functor :: Inst (Functor m)
  functor = Functor (<$>) ($>)

  (<*>) :: m (a -> b) -> m a -> m b
  (<*>) mab ma = mab >>= \ab -> ma >>= \a -> pure $ ab a

  liftA2 :: (a -> b -> c) -> m a -> m b -> m c
  liftA2 abc fa fb = abc <$> fa <*> fb

  (*>) :: m a -> m b -> m b
  (*>) ma mb = (flip const) <$> ma <*> mb

  (<*) :: m a -> m b -> m a
  (<*) ma mb = const <$> ma <*> mb

  applicative :: Inst (Applicative m)
  applicative = Applicative functor pure (<*>) liftA2 (*>) (<*)

type f ~> g = forall x. f x -> g x

data f ~⋅~> g = MMorph
  { convert :: Inst (Monad f) -> Inst (Monad g)
  , nat :: Monad f => f ~> g
  }

class Monad m => Teletype m where
  read  :: m String
  write :: String -> m ()

mkInst ''Teletype

mapTeletype :: (f ~⋅~> g) -> Inst (Teletype f) -> Inst (Teletype g)
mapTeletype (MMorph { convert, nat }) [email protected](Teletype m r w) = t ==> Teletype (convert m) (nat r) (nat . w)

newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }

monadReaderT :: forall r m. Inst (Monad m) -> Inst (Monad (ReaderT r m))
monadReaderT m = m ==> ezmonad (>>=′) pure'
  where
  (>>=′) :: Monad m => (::>>=) (ReaderT r m)
  (ReaderT ma) >>=′ ((runReaderT .) -> amb) = ReaderT $ \r -> ma r >>= ($ r) . amb

  pure' :: Monad m => Pure (ReaderT r m)
  pure' = ReaderT . pure . pure

liftReaderT :: m ~⋅~> ReaderT r m
liftReaderT = MMorph monadReaderT (ReaderT . pure)

newtype StateT s m a = StateT { runStateT :: s -> m (a, s) }

monadStateT :: forall s m. Inst (Monad m) -> Inst (Monad (StateT s m))
monadStateT m = m ==> ezmonad (>>=′) pure'
  where
  (>>=′) :: Monad m => (::>>=) (StateT s m)
  (StateT ma) >>=′ ((runStateT .) -> amb) = StateT $ \s -> ma s >>= \(a, s') -> amb a s'

  pure' :: Monad m => Pure (StateT s m)
  pure' a = StateT $ \s -> pure (a, s)

liftStateT :: m ~⋅~> StateT s m
liftStateT = MMorph monadStateT (\ma -> StateT $ \s -> (, s) <$> ma)

test :: Inst (Teletype f) -> Inst (Teletype (ReaderT r (StateT s f)))
test = mapTeletype liftReaderT . mapTeletype liftStateT

instance Foo a = bar

class Group a where
  unit :: a
  (<>) :: a -> a -> a
  inverse :: a -> a

sumRational, prodRational :: Group Rational
sumRational = Group{
    unit = 0
  , (<>) = (+)
  , inverse = negate
  }
prodRational = Group{
    unit = 1
  , (<>) = (*)
  , inverse = (1 /)
  }

foo = 1 <> 2 where Group{..} = prodRational