SFunctor.hs

-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

newtype
    HyperFree
        (f :: InsClass -> Type -> Type)
        (e :: ASigClass)
        (a :: Type) = HyperFree
    {unHyperFree :: (f :# GetSigClass e) a}

type SigClass = (ASigClass -> Type -> Type) -> ASigClass -> Type -> Type
newtype ASigClass = ASigClass SigClass

type family GetSigClass (a :: ASigClass) where
    GetSigClass ('ASigClass e) = e

infixr 4 #, :#
type f # e = f ('ASigClass e)
type f :# e = f (e (HyperFree f) # e)

class HyperFunctor (h :: ASigClass -> Type -> Type) where
    hyfmap :: ((e1 h # e1) ~> (e2 h # e2)) -> (h # e1) ~> (h # e2)

instance Freer c f => HyperFunctor (HyperFree f) where
    hyfmap f (HyperFree a) = HyperFree $ transformFreer f a
    {-# INLINE hyfmap #-}

class SFunctor (e :: SigClass) where
    sfmap ::
        (HyperFunctor h, SFunctor e1, SFunctor e2) =>
        (forall x. SFunctor x => (e1 h # x) ~> (e2 h # x)) ->
        (e h # e1) ~> (e h # e2)
    transHyper ::
        (forall x. SFunctor x => (h # x) ~> (h' # x)) ->
        (e h # e') ~> (e h' # e')

hysfmap ::
    (HyperFunctor h, SFunctor e1, SFunctor e2) =>
    (forall x. SFunctor x => (e1 h # x) ~> (e2 h # x)) ->
    (h # e1) ~> (h # e2)
hysfmap f = hyfmap $ sfmap f . f
{-# INLINE hysfmap #-}

shyfmap ::
    (HyperFunctor h, SFunctor e, SFunctor e1, SFunctor e2) =>
    (h # e1) ~> (h # e2) ->
    (e h # e1) ~> (e h # e2)
shyfmap f = sfmap undefined

type InsClass = Type -> Type