Higher Profunctors

HProfunctor.hs

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

class HProfunctor (p :: (* -> *) -> (* -> *) -> * -> *) where
  hdimap :: (f ~> g) -> (h ~> i) -> p g h ~> p f i

instance HProfunctor Ran where
  hdimap fg hi r = Ran $ \k -> hi $ runRan r (fg . k)

instance HProfunctor Lan where
  hdimap fg hi (Lan gbx h) = Lan (gbx . fg) (hi h)

class (HProfunctor p) => HStrong p where
  hfirst :: p f g ~> p (Product f h) (Product g h)
  hsecond :: p f g ~> p (Product h f) (Product h g)

class (HProfunctor p) => HChoice p where
  hleft :: p f g ~> p (Sum f h) (Sum g h)
  hright :: p f g ~> p (Sum h f) (Sum h g)

ffirst :: Product f g a -> f a
ffirst (Pair f _) = f

instance HStrong Ran where
  hfirst r = Ran $ \k -> _h $ runRan r (ffirst . k)

instance HChoice Lan where
  hleft (Lan fbx gb) = Lan _h (InL gb)

class (HProfunctor p) => HCoStrong p where
  hunfirst :: p (Product f h) (Product g h) ~> p f g
  hunsecond :: p (Product h f) (Product h g) ~> p f g

instance HCoStrong Ran where
  hunfirst r = Ran $ \k -> ffirst $ runRan r _h

instance HCoStrong Lan where
  hunfirst (Lan fhbx ghb) = Lan _h (ffirst ghb)