SFunctorV4.hs

{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE UndecidableInstances #-}

-- 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/.

module Control.Hefty where

import Control.Applicative (Alternative)
import Control.Effect.Class (LiftIns (LiftIns), NopS, unliftIns, type (~>))
import Control.Effect.Class.Except (CatchS)
import Control.Effect.Class.Machinery.HFunctor (HFunctor, caseH, hfmap, (:+:) (Inl, Inr))
import Control.Effect.Free (InsClass)
import Control.Freer (Freer, interpretFreer, liftIns, transformFreer)
import Control.Monad (MonadPlus)
import Control.Monad.Base (MonadBase)
import Control.Monad.IO.Class (MonadIO)
import Data.Kind (Type)

newtype
    Hefty
        (f :: InsClass -> Type -> Type)
        (e :: SigClass)
        (a :: Type) = Hefty
    {unHefty :: f (e (Hefty f e)) a}

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

deriving newtype instance Functor (f (e (Hefty f e))) => Functor (Hefty f e)
deriving newtype instance Applicative (f (e (Hefty f e))) => Applicative (Hefty f e)
deriving newtype instance Alternative (f (e (Hefty f e))) => Alternative (Hefty f e)
deriving newtype instance Monad (f (e (Hefty f e))) => Monad (Hefty f e)
deriving newtype instance MonadPlus (f (e (Hefty f e))) => MonadPlus (Hefty f e)
deriving newtype instance (MonadBase b (f (e (Hefty f e))), Monad b) => MonadBase b (Hefty f e)
deriving newtype instance MonadIO (f (e (Hefty f e))) => MonadIO (Hefty f e)
deriving newtype instance MonadFail (f (e (Hefty f e))) => MonadFail (Hefty f e)

deriving stock instance Foldable (f (e (Hefty f e))) => Foldable (Hefty f e)
deriving stock instance Traversable (f (e (Hefty f e))) => Traversable (Hefty f e)

deriving newtype instance Eq (f (e (Hefty f e)) a) => Eq (Hefty f e a)
deriving newtype instance Ord (f (e (Hefty f e)) a) => Ord (Hefty f e a)
deriving newtype instance Read (f (e (Hefty f e)) a) => Read (Hefty f e a)
deriving newtype instance Show (f (e (Hefty f e)) a) => Show (Hefty f e a)

overHefty ::
    (f (e (Hefty f e)) a -> f' (e' (Hefty f' e')) b) ->
    Hefty f e a ->
    Hefty f' e' b
overHefty f = Hefty . f . unHefty
{-# INLINE overHefty #-}

data ((e :: SigClass) +# (f :: Type -> Type)) (a :: Type) where
    HyperFunctorPlusT :: h (e :+: r) a -> (e +# h r) a

class HyperFunctor (h :: SigClass -> Type -> Type) where
    hyfmap :: (e (h e) ~> e' (h e')) -> h e ~> h e'

instance Freer c f => HyperFunctor (Hefty f) where
    hyfmap f = Hefty . transformFreer f . unHefty
    {-# INLINE hyfmap #-}

class SFunctor (e :: SigClass) where
    sfmap ::
        (HyperFunctor h, SFunctor e1, SFunctor e2) =>
        (forall ex. SFunctor ex => h (ex :+: e1) ~> h (ex :+: e2)) ->
        e (h e1) ~> e (h e2)

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

shyfmap ::
    forall e e1 e2 h.
    ( SFunctor e
    , SFunctor e1
    , SFunctor e2
    , HyperFunctor h
    ) =>
    (forall ex. e1 (h ex) ~> e2 (h ex)) ->
    e (h e1) ~> e (h e2)
shyfmap f = sfmap $ hysfmap $ caseH Inl (Inr . f)
{-# INLINE shyfmap #-}

hsfmap ::
    forall e e' h.
    (HyperFunctor h, SFunctor e, SFunctor e') =>
    (forall f. e f ~> e' f) ->
    h e ~> h e'
hsfmap f = hyfmap $ f . sfmap (rightHyperFunctor f)
{-# INLINE hsfmap #-}

rightHyperFunctor ::
    forall l r r' h.
    (HyperFunctor h, SFunctor l, SFunctor r, SFunctor r') =>
    (forall ex. r (h (ex :+: r')) ~> r' (h (ex :+: r'))) ->
    h (l :+: r) ~> h (l :+: r')
rightHyperFunctor f =
    hyfmap $ caseH (Inl . sfmapR f) (Inr . f . sfmapR f)

sfmapR ::
    forall e l r r' h.
    (HyperFunctor h, SFunctor e, SFunctor l, SFunctor r, SFunctor r') =>
    (forall ex. r (h (ex :+: r')) ~> r' (h (ex :+: r'))) ->
    e (h (l :+: r)) ~> e (h (l :+: r'))
sfmapR f =
    sfmap $
        assocHyperFunctorR
            . rightHyperFunctor f
            . assocHyperFunctorL

assocHyperFunctorL ::
    forall e1 e2 e3 h.
    (HyperFunctor h, SFunctor e1, SFunctor e2, SFunctor e3) =>
    h (e1 :+: (e2 :+: e3)) ~> h ((e1 :+: e2) :+: e3)
assocHyperFunctorL = hysfmap assocLSumH

assocHyperFunctorR ::
    forall e1 e2 e3 h.
    (HyperFunctor h, SFunctor e1, SFunctor e2, SFunctor e3) =>
    h ((e1 :+: e2) :+: e3) ~> h (e1 :+: (e2 :+: e3))
assocHyperFunctorR = hysfmap assocRSumH

instance SFunctor (LiftIns e) where
    sfmap _ = LiftIns . unliftIns
    {-# INLINE sfmap #-}

instance
    (SFunctor e1, SFunctor e2) =>
    SFunctor (e1 :+: e2)
    where
    sfmap f = caseH (Inl . sfmap f) (Inr . sfmap f)
    {-# INLINE sfmap #-}

newtype ViaHFunctor (e :: SigClass) f a = ViaHFunctor {unViaHFunctor :: e f a}
    deriving (HFunctor)

instance HFunctor e => SFunctor (ViaHFunctor e) where
    sfmap f = hfmap $ absurdHyperFunctorL . f . weakenHyperFunctorL
    {-# INLINE sfmap #-}

absurdHyperFunctorL ::
    forall e h.
    (HyperFunctor h, SFunctor e) =>
    h (NopS :+: e) ~> h e
absurdHyperFunctorL = hsfmap $ caseH (\case {}) id
{-# INLINE absurdHyperFunctorL #-}

weakenHyperFunctorL ::
    forall l r h.
    (HyperFunctor h, SFunctor l, SFunctor r) =>
    h r ~> h (l :+: r)
weakenHyperFunctorL = hsfmap Inr
{-# INLINE weakenHyperFunctorL #-}

assocLSumH :: (e1 :+: (e2 :+: e3)) f ~> ((e1 :+: e2) :+: e3) f
assocLSumH = caseH (Inl . Inl) (caseH (Inl . Inr) Inr)

assocRSumH :: ((e1 :+: e2) :+: e3) f ~> (e1 :+: (e2 :+: e3)) f
assocRSumH = caseH (caseH Inl (Inr . Inl)) (Inr . Inr)

data RunCatch err m a where
    RunCatch :: (CatchS err +# m) a -> RunCatch err m (Either err a)

deriving via ViaHFunctor (CatchS err) instance SFunctor (CatchS err)

instance SFunctor (RunCatch err) where
    sfmap f (RunCatch (HyperFunctorPlusT a)) =
        RunCatch $ HyperFunctorPlusT $ f a
    {-# INLINE sfmap #-}

interpretR ::
    forall r l f c.
    (Freer c f, SFunctor l, SFunctor r) =>
    (forall ex. SFunctor ex => r (Hefty f (ex :+: l)) ~> Hefty f (ex :+: l)) ->
    Hefty f (l :+: r) ~> Hefty f l
interpretR i =
    overHefty $
        interpretFreer $
            caseH
                (liftIns . sfmap int)
                ( unHefty
                    . absurdHyperFunctorL
                    . i
                    . sfmap (hysfmap (caseH Inl (Inr . Inr)) . int)
                )
  where
    int :: SFunctor ex' => Hefty f (ex' :+: (l :+: r)) ~> Hefty f (ex' :+: l)
    int =
        interpretR (hysfmap assocRSumH . i . shyfmap assocLSumH)
            . hysfmap assocLSumH