Free things

Whatever.hs

{-# LANGUAGE ImpredicativeTypes #-}
module Whatever where

import Data.Profunctor

newtype ForgetP p a b = ForgetP { runForgetP :: p a b }
  deriving Profunctor

class (forall p. Profunctor p => thing (t p)) => Free thing t
  where
  fwd :: (Profunctor p, thing q) => (p :-> ForgetP q) -> t p :-> q
  bwd :: (Profunctor p, thing q) => (t p :-> q) -> p :-> ForgetP q

data TheFree thing p a b = TheFree { runFree :: forall q. (Profunctor q, thing q) => (p :-> ForgetP q) -> q a b }

instance Profunctor p => Profunctor (TheFree thing p)
  where
  dimap f g (TheFree x) = TheFree $ \cb -> dimap f g $ x cb

instance Profunctor p => Strong (TheFree Strong p)
  where
  first' (TheFree p) = TheFree $ \cb -> first' $ p cb

instance Free Strong (TheFree Strong)
  where
  fwd cb (TheFree p) = p cb
  bwd cb p = ForgetP $ cb $ TheFree $ runForgetP . ($ p)

instance Profunctor p => Costrong (TheFree Costrong p)
  where
  unfirst (TheFree p) = TheFree $ \cb -> unfirst $ p cb

instance Free Costrong (TheFree Costrong)
  where
  fwd cb (TheFree p) = p cb
  bwd cb p = ForgetP $ cb $ TheFree $ runForgetP . ($ p)

instance Profunctor p => Choice (TheFree Choice p)
  where
  left' (TheFree p) = TheFree $ \cb -> left' $ p cb

instance Free Choice (TheFree Choice)
  where
  fwd cb (TheFree p) = p cb
  bwd cb p = ForgetP $ cb $ TheFree $ runForgetP . ($ p)

instance Profunctor p => Cochoice (TheFree Cochoice p)
  where
  unleft (TheFree p) = TheFree $ \cb -> unleft $ p cb

instance Free Cochoice (TheFree Cochoice)
  where
  fwd cb (TheFree p) = p cb
  bwd cb p = ForgetP $ cb $ TheFree $ runForgetP . ($ p)

-- ...