Haskell - 使用递归方案的通用多态代数数据类型的仿函数实例

Question

问题：

最近我在这里问了以下问题，询问如何为任意多态 ADT（代数数据类型）（如列表、树等）创建通用映射函数和 Functor 的通用实例：

Functor instance for generic polymorphic ADTs in Haskell?

现在，我正在尝试重新制定上述内容以与recursion-schemes 兼容。即，我不想定义基仿函数，然后将类型定义为其固定点，而是一方面定义类型，另一方面定义基仿函数，并使用Base 系列类型将它们关联起来。

所以不要这样做：

data ListF a b = NilF | ConsF a b
newtype Fix f = Fix { unFix :: f (Fix f) }
type List a = Fix (ListF a)

我想这样做：

data ListF a b = NilF | ConsF a b
data List a = Nil | Cons a (List a)
type instance Base (List a) = ListF a

这样我可以利用recursion-schemes 库的强大功能，同时仍然能够为任何这些多态类型定义一个通用的fmap。不仅如此，能够使用“正常”类型而不是固定点的类型同义词是一种更愉快的体验。

尝试：

最初，我一方面考虑拥有一个Bifunctor 实例，然后以某种方式强制或使其等于相应的Base 系列实例。目前我只能考虑使用Data.Type.Equality中的a :~: b。这是我到目前为止所得到的：

{-# LANGUAGE TypeOperators, Rank2Types #-}
import Data.Bifunctor
import Data.Functor.Foldable
import Data.Type.Equality

gmap :: (Bifunctor p, Foldable (f a), Unfoldable (f b)) => 
        (forall x. p x :~: Base (f x)) -> (a -> b) -> f a -> f b
gmap refl f = cata alg
    where
        alg = embed . 
              castWith (apply refl Refl) . 
              bimap f id . 
              castWith (apply (sym refl) Refl)

我的问题在于尝试定义Functor 的实例。我不知道在定义实例时如何指定那些特定的类型约束。 我正在考虑以某种方式创建一个类型类Equals，然后做这样的事情：

instance (Bifunctor p, Foldable (f a), Unfoldable (f b), Equals (p a) (Base (f a))) 
    => Functor f where

但我不知道这是否可能，也不知道我是否以正确的方式接近它（例如，我不确定我对 gmap 的定义是否正确）。

---

作为参考，这是来自原始 SO 问题的通用 gmap 的定义：

gmap :: (Bifunctor f) => (a -> b) -> Fix (f a) -> Fix (f b)
gmap f = unwrapFixBifunctor . cata alg . wrapFixBifunctor
  where
    alg = Fix . bimap f id

    unwrapFixBifunctor :: (Bifunctor f) => Fix (WrappedBifunctor f a) -> Fix (f a)
    unwrapFixBifunctor = Fix . unwrapBifunctor . fmap unwrapFixBifunctor . unFix

    wrapFixBifunctor :: (Bifunctor f) => Fix (f a) -> Fix (WrappedBifunctor f a)
    wrapFixBifunctor = Fix . fmap wrapFixBifunctor . WrapBifunctor . unFix

---

更新：

有人指出，gmap 的以下定义会更通用，并且不需要任何奇怪的类型级相等应用：

gmap :: (Foldable t, Unfoldable d, Bifunctor p, Base d ~ p b, Base t ~ p a)
        => (a -> b) -> t -> d
gmap f = cata ( embed . bimap f id )

但是，我仍然找不到创建具有类似类型约束的Functor 实例的方法

Answer 1

With a little help from @kosmikus，只要你对 UndecidableInstances 没问题，我就能破解一个可以工作的版本。

这个想法是从gmap 的上下文中删除对a 和b 的所有引用，方法是要求forall x. Foldable (f x) 等等，使用constraints 包进行编码：

{-# LANGUAGE TypeFamilies, ScopedTypeVariables, TypeOperators, ConstraintKinds #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
import Data.Bifunctor
import Data.Functor.Foldable
import Data.Constraint
import Data.Constraint.Forall

-- https://stackoverflow.com/a/28067872/477476
class (p x ~ Base (f x)) => Based p f x
instance (p x ~ Base (f x)) => Based p f x

gmap :: forall p f a b. ( Bifunctor p 
                        , ForallF Foldable f
                        , ForallF Unfoldable f
                        , Forall (Based p f))
     => (a -> b) -> f a -> f b
gmap f = case (instF :: ForallF Foldable f :- Foldable (f a)) of
  Sub Dict -> case (instF :: ForallF Unfoldable f :- Unfoldable (f b)) of
    Sub Dict -> case (inst :: Forall (Based p f) :- Based p f a) of
      Sub Dict -> case (inst :: Forall (Based p f) :- Based p f b) of
        Sub Dict -> cata (embed . bimap f id)

有了a和b，我们可以把gmap变成fmap：

{-# LANGUAGE UndecidableInstances #-}
instance (Bifunctor p, ForallF Foldable f, ForallF Unfoldable f, Forall (Based p f)) => Functor f where
    fmap = gmap

编辑添加：上述实例的问题在于它会匹配正确类型的任何类型，如@gonzaw 所述：如果你有

data ListT a = NilT
             | ConsT a (ListT a)

data ListF a b = NilF
               | ConsF a b

type instance Base (ListT a) = ListF a

instance Bifunctor ListF where ...
instance Functor (ListF a) where ...
instance Foldable (ListT a) where ...
instance Unfoldable (ListT a) where ...

那么你得到的比你预想的要多，通用的 Functor 实例和 ListF a(!) 的实例重叠。

您可以再添加一层 newtype 包装器来解决这个问题：如果您有

newtype F f x = F{ unF ::  (f x) }

instance (Bifunctor p, ForallF Foldable f, ForallF Unfoldable f, Forall (Based p f)) => Functor (F f) where
    fmap f = F . gmap f . unF

type ListT' = F ListT

最后是以下类型检查：

*Main> unF . fmap (+1) . F $ ConsT 1 $ ConsT 2 NilT
ConsT 2 (ConsT 3 NilT)

这层额外的newtype 包装是否适合您是您必须决定的事情。