HKTs via type classes

HKT.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
import Unsafe.Coerce
import Prelude hiding ((>>=))

data App a b
class TypeApp cons k0 k1 | k1 -> cons k0, cons k0 -> k1 where
  inj :: k1 -> App cons k0
  inj = unsafeCoerce

  prj :: App cons k0 -> k1
  prj = unsafeCoerce

class Functor' cons where
  fmap' :: forall a b. (a -> b) -> App cons a -> App cons b
class Functor' m => Monad' m where
  pure' :: a -> App m a
  join' :: App m (App m a) -> App m a
  (>>=) :: forall a b. App m a -> (a -> App m b) -> App m b
  m >>= k = join' $ fmap' k m

data ListType = ListType
instance TypeApp ListType a [a]
instance Functor' ListType where
  fmap' f xs = inj $ map f $ prj xs
instance Monad' ListType where
  pure' a = inj [a]
  join' = inj . concatMap prj . prj

my_lst = inj [1, 2, 3]
main = do
  print $ prj $ fmap' (+1) my_lst
  print $ prj $ inj [1, 2, 3] >>= \x -> inj [2*x, 3*x]
-- [2,3,4]
-- [2,3,4,6,6,9]

my improvement based on https://link.springer.com/chapter/10.1007/978-3-319-07151-0_8 .