{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ViewPatterns #-}
module Data.HFunctor (
HFunctor(..)
, overHFunctor
, Inject(..)
, HBind(..)
, ProxyF(..)
, ConstF(..)
, HLift(..), retractHLift
, HFree(..), foldHFree, retractHFree
) where
import Control.Applicative.Backwards
import Control.Applicative.Free
import Control.Applicative.Lift
import Control.Applicative.ListF
import Control.Applicative.Step
import Control.Comonad.Trans.Env
import Control.Monad.Freer.Church
import Control.Monad.Reader
import Control.Monad.Trans.Compose
import Control.Monad.Trans.Identity
import Control.Natural
import Control.Natural.IsoF
import Data.Coerce
import Data.Data
import Data.Deriving
import Data.Functor.Bind
import Data.Functor.Classes
import Data.Functor.Coyoneda
import Data.Functor.Plus
import Data.Functor.Product
import Data.Functor.Reverse
import Data.Functor.Sum
import Data.Functor.These
import Data.HFunctor.Internal
import Data.List.NonEmpty (NonEmpty(..))
import Data.Pointed
import Data.Semigroup.Foldable
import GHC.Generics
import qualified Control.Alternative.Free as Alt
import qualified Control.Applicative.Free.Fast as FAF
import qualified Control.Applicative.Free.Final as FA
import qualified Data.Map as M
import qualified Data.Map.NonEmpty as NEM
overHFunctor
:: HFunctor t
=> f <~> g
-> t f <~> t g
overHFunctor f = isoF (hmap (viewF f)) (hmap (reviewF f))
data ProxyF f a = ProxyF
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
deriveShow1 ''ProxyF
deriveRead1 ''ProxyF
deriveEq1 ''ProxyF
deriveOrd1 ''ProxyF
instance HFunctor ProxyF where
hmap _ = coerce
data ConstF e f a = ConstF { getConstF :: e }
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data)
deriveShow1 ''ConstF
deriveRead1 ''ConstF
deriveEq1 ''ConstF
deriveOrd1 ''ConstF
instance HFunctor (ConstF e) where
hmap _ = coerce
data HLift t f a = HPure (f a)
| HOther (t f a)
deriving Functor
instance (Show1 (t f), Show1 f) => Show1 (HLift t f) where
liftShowsPrec sp sl d = \case
HPure x -> showsUnaryWith (liftShowsPrec sp sl) "HPure" d x
HOther x -> showsUnaryWith (liftShowsPrec sp sl) "HOther" d x
deriving instance (Show (f a), Show (t f a)) => Show (HLift t f a)
deriving instance (Read (f a), Read (t f a)) => Read (HLift t f a)
deriving instance (Eq (f a), Eq (t f a)) => Eq (HLift t f a)
deriving instance (Ord (f a), Ord (t f a)) => Ord (HLift t f a)
instance (Eq1 (t f), Eq1 f) => Eq1 (HLift t f) where
liftEq eq = \case
HPure x -> \case
HPure y -> liftEq eq x y
HOther _ -> False
HOther x -> \case
HPure _ -> False
HOther y -> liftEq eq x y
instance (Ord1 (t f), Ord1 f) => Ord1 (HLift t f) where
liftCompare c = \case
HPure x -> \case
HPure y -> liftCompare c x y
HOther _ -> LT
HOther x -> \case
HPure _ -> GT
HOther y -> liftCompare c x y
instance HFunctor t => HFunctor (HLift t) where
hmap f = \case
HPure x -> HPure (f x)
HOther x -> HOther (hmap f x)
retractHLift
:: Inject t
=> HLift t f a
-> t f a
retractHLift = \case
HPure x -> inject x
HOther x -> x
data HFree t f a = HReturn (f a)
| HJoin (t (HFree t f) a)
deriving instance (Functor f, Functor (t (HFree t f))) => Functor (HFree t f)
foldHFree
:: forall t f g. HFunctor t
=> (f ~> g)
-> (t g ~> g)
-> (HFree t f ~> g)
foldHFree f g = go
where
go :: HFree t f ~> g
go (HReturn x) = f x
go (HJoin x) = g (hmap go x)
retractHFree
:: HBind t
=> HFree t f a
-> t f a
retractHFree = \case
HReturn x -> inject x
HJoin x -> hbind retractHFree x
instance (Show1 (t (HFree t f)), Show1 f) => Show1 (HFree t f) where
liftShowsPrec sp sl d = \case
HReturn x -> showsUnaryWith (liftShowsPrec sp sl) "HReturn" d x
HJoin x -> showsUnaryWith (liftShowsPrec sp sl) "HJoin" d x
instance (Show1 (t (HFree t f)), Show1 f, Show a) => Show (HFree t f a) where
showsPrec = liftShowsPrec showsPrec showList
instance HFunctor t => HFunctor (HFree t) where
hmap :: forall f g. (f ~> g) -> HFree t f ~> HFree t g
hmap f = go
where
go :: HFree t f ~> HFree t g
go = \case
HReturn x -> HReturn (f x)
HJoin x -> HJoin (hmap go x)
class HFunctor t => Inject t where
inject :: f ~> t f
{-# MINIMAL inject #-}
class Inject t => HBind t where
hbind :: (f ~> t g) -> t f ~> t g
hbind f = hjoin . hmap f
hjoin :: t (t f) ~> t f
hjoin = hbind id
{-# MINIMAL hbind | hjoin #-}
instance Inject Coyoneda where
inject = liftCoyoneda
instance Inject Ap where
inject = liftAp
instance Inject ListF where
inject = ListF . (:[])
instance Inject NonEmptyF where
inject = NonEmptyF . (:| [])
instance Inject MaybeF where
inject = MaybeF . Just
instance Monoid k => Inject (NEMapF k) where
inject = NEMapF . NEM.singleton mempty
instance Monoid k => Inject (MapF k) where
inject = MapF . M.singleton mempty
instance Inject Step where
inject = Step 0
instance Inject Steps where
inject = Steps . NEM.singleton 0
instance Inject Flagged where
inject = Flagged False
instance Inject (These1 f) where
inject = That1
instance Applicative f => Inject (Comp f) where
inject x = pure () :>>= const x
instance Applicative f => Inject ((:.:) f) where
inject x = Comp1 $ pure x
instance Plus f => Inject ((:*:) f) where
inject = (zero :*:)
instance Plus f => Inject (Product f) where
inject = Pair zero
instance Inject ((:+:) f) where
inject = R1
instance Inject (Sum f) where
inject = InR
instance Inject (M1 i c) where
inject = M1
instance Inject Alt.Alt where
inject = Alt.liftAlt
instance Inject Free where
inject = liftFree
instance Inject Free1 where
inject = liftFree1
instance Inject FA.Ap where
inject = FA.liftAp
instance Inject FAF.Ap where
inject = FAF.liftAp
instance Inject IdentityT where
inject = coerce
instance Inject Lift where
inject = Other
instance Inject MaybeApply where
inject = MaybeApply . Left
instance Inject Backwards where
inject = Backwards
instance Inject WrappedApplicative where
inject = WrapApplicative
instance Inject (ReaderT r) where
inject = ReaderT . const
instance Monoid e => Inject (EnvT e) where
inject = EnvT mempty
instance Inject Reverse where
inject = Reverse
instance Inject ProxyF where
inject _ = ProxyF
instance Monoid e => Inject (ConstF e) where
inject _ = ConstF mempty
instance (Inject s, Inject t) => Inject (ComposeT s t) where
inject = ComposeT . inject . inject
instance HFunctor t => Inject (HLift t) where
inject = HPure
instance HFunctor t => Inject (HFree t) where
inject = HReturn
instance HBind Coyoneda where
hbind f (Coyoneda g x) = g <$> f x
instance HBind Ap where
hbind = runAp
instance HBind ListF where
hbind f = foldMap f . runListF
instance HBind NonEmptyF where
hbind f = foldMap1 f . runNonEmptyF
instance HBind MaybeF where
hbind f = foldMap f . runMaybeF
instance HBind Step where
hbind f (Step n x) = Step (n + m) y
where
Step m y = f x
instance HBind Flagged where
hbind f (Flagged p x) = Flagged (p || q) y
where
Flagged q y = f x
instance Alt f => HBind (These1 f) where
hbind f = \case
This1 x -> This1 x
That1 y -> f y
These1 x y -> case f y of
This1 x' -> This1 (x <!> x')
That1 y' -> That1 y'
These1 x' y' -> These1 (x <!> x') y'
instance Plus f => HBind ((:*:) f) where
hbind f (x :*: y) = (x <!> x') :*: y'
where
x' :*: y' = f y
instance Plus f => HBind (Product f) where
hbind f (Pair x y) = Pair (x <!> x') y'
where
Pair x' y' = f y
instance HBind ((:+:) f) where
hbind f = \case
L1 x -> L1 x
R1 y -> f y
instance HBind (Sum f) where
hbind f = \case
InL x -> InL x
InR y -> f y
instance HBind (M1 i c) where
hbind f (M1 x) = f x
instance HBind Alt.Alt where
hbind = Alt.runAlt
instance HBind Free where
hbind = interpretFree
instance HBind Free1 where
hbind = interpretFree1
instance HBind FA.Ap where
hbind = FA.runAp
instance HBind FAF.Ap where
hbind = FAF.runAp
instance HBind IdentityT where
hbind f = f . runIdentityT
instance HBind Lift where
hbind = elimLift point
instance HBind MaybeApply where
hbind f = either f point . runMaybeApply
instance HBind Backwards where
hbind f = f . forwards
instance HBind WrappedApplicative where
hbind f = f . unwrapApplicative
instance HBind Reverse where
hbind f = f . getReverse
instance HBind ProxyF where
hbind _ = coerce
instance Monoid e => HBind (EnvT e) where
hbind f (EnvT e x) = EnvT (e <> e') y
where
EnvT e' y = f x
instance (HBind t, Inject t) => HBind (HLift t) where
hbind f = \case
HPure x -> f x
HOther x -> HOther $ (`hbind` x) $ \y -> case f y of
HPure z -> inject z
HOther z -> z
instance HFunctor t => HBind (HFree t) where
hbind f = \case
HReturn x -> f x
HJoin x -> HJoin $ hmap (hbind f) x