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

infixr 5 #+#, #+, +#, :+:

newtype
    (:+:)
        (e1 :: SigClass)
        (e2 :: SigClass)
        (h :: ASigClass -> Type -> Type)
        (e :: ASigClass)
        (a :: Type) = SumH {unSumH :: (e1 h e + e2 h e) a}
    deriving newtype (Generic, Generic1, Contravariant, Eq, Ord, Functor, Foldable)
    deriving stock (Traversable, Read, Show)

type (e1 :: SigClass) +# (e2 :: ASigClass) = 'ASigClass (e1 :+: GetSigClass e2)
type (e1 :: ASigClass) #+ (e2 :: SigClass) = 'ASigClass (GetSigClass e1 :+: e2)
type (e1 :: ASigClass) #+# (e2 :: ASigClass) = 'ASigClass (GetSigClass e1 :+: GetSigClass e2)

class SFunctor (e :: SigClass) where
    sfmap ::
        HyperFunctor h =>
        (forall x. (h # x :+: e1) ~> (h # x :+: e2)) ->
        (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 = undefined
{-# INLINE hysfmap #-}

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

instance (SFunctor e1, SFunctor e2) => SFunctor (e1 :+: e2) where
    sfmap f = SumH . caseSum (L1 . sfmap f) (R1 . sfmap f) . unSumH
    {-# INLINE sfmap #-}

    transHyper f = SumH . caseSum (L1 . transHyper f) (R1 . transHyper f) . unSumH
    {-# INLINE transHyper #-}

data StateI s a where
    Put :: s -> StateI s ()
    Get :: StateI s s

data RunState s h e a where
    RunState :: h (LiftIns (StateI s) +# e) a -> RunState s h e (s, a)

instance SFunctor (RunState s) where
    sfmap f (RunState a) = RunState $ f a