PolyKinds

{-# LANGUAGE PolyKinds #-}
module FreeArr where

import Data.Profunctor
import Data.Profunctor.Composition

data HHFree (h :: (k -> k -> *) -> (k -> k -> *) -> (k -> k -> *)) i f a b
    = HHDone (i a b)
    | HHMore (h f (HHFree h i f) a b)

type FreeArr = HHFree Procompose (->)

-- is it an arrow?
-- check.
--

-- Category
identity :: FreeArr f a a
identity = HHDone id

rightMap :: Profunctor f => (b -> c) -> FreeArr f a b -> FreeArr f a c
rightMap f (HHDone g) = HHDone (f . g)
rightMap f (HHMore (Procompose x xs)) = HHMore (Procompose (rmap f x) xs)

compose :: Profunctor f => FreeArr f b c -> FreeArr f a b -> FreeArr f a c
compose (HHDone f) ab = rightMap f ab
compose (HHMore (Procompose x xs)) ab = HHMore $ Procompose x $ compose xs ab

-- Arrow
arr :: (b -> c) -> FreeArr f b c
arr f = HHDone f

-- arr id = id
-- so far so good.

-- But with 'first' we'll need 'Strong f' or similar-ish
-- constraint.
first :: Strong f => FreeArr f b c -> FreeArr f (b, d) (c, d)
first (HHDone x) = HHDone (first' x)
first (HHMore (Procompose x xs)) =
    HHMore (Procompose (first' x) (first xs))

-- Ok. Works somehow.

-------------------------------------------------------------------------------
-- What about (***)
-------------------------------------------------------------------------------

-- Exercise: try yourself!