HyperFree2.hs

{-# 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.HyperFree where

import Control.Applicative (Alternative)
import Control.Monad (MonadPlus)
import Control.Monad.Base (MonadBase)
import Control.Monad.IO.Class (MonadIO)
import Data.Data (Data)
import Data.Free.Sum (type (+))
import Data.Functor.Contravariant (Contravariant)
import Data.Kind (Type)
import GHC.Generics (Generic, Generic1)

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

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

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

type f # e = HyperFree f ('ASigClass e)

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, Read, Show, Eq, Ord)
    deriving stock (Functor, Foldable, Traversable, Data)

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

type family UnliftSig (e :: ASigClass) (h :: ASigClass -> Type -> Type) :: Type -> Type where
    UnliftSig ('ASigClass (e1 +# e2)) h =
        e1 h ('ASigClass (e1 +# e2)) + e2 h ('ASigClass (e1 +# e2))
    UnliftSig ('ASigClass e) h = e h ('ASigClass e)

type e :# f = UnliftSig e (HyperFree f)

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

deriving stock instance Foldable (f (e :# f)) => Foldable (HyperFree f e)
deriving stock instance Traversable (f (e :# f)) => Traversable (HyperFree f e)

deriving newtype instance Eq (f (e :# f) a) => Eq (HyperFree f e a)
deriving newtype instance Ord (f (e :# f) a) => Ord (HyperFree f e a)
deriving newtype instance Read (f (e :# f) a) => Read (HyperFree f e a)
deriving newtype instance Show (f (e :# f) a) => Show (HyperFree f e a)

newtype
    LiftIns
        (e :: Type -> Type)
        (h :: ASigClass -> Type -> Type)
        (eh :: ASigClass)
        (a :: Type) = LiftInstruction {unliftIns :: e a}
    deriving stock (Functor, Foldable, Traversable)