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

Question

问题：

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

Haskell中通用多态ADT的函子实例？

现在，我正在尝试重新构造上述内容，以与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

在@kosmikus的一点帮助下 ，只要您对UndecidableInstances 满意 ，我就可以破解一个可以正常工作的版本。

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

{-# 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)

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

那么您得到的ListF a超过您的讨价还价，通用Functor实例与ListF a （！）实例重叠。

您可以再添加一层新包装，以解决此问题：

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包装是否可接受的东西，你必须做出决定。