为自定义 ZipList 实现 Applicative

Question

这来自Haskell from First Principles一书中的一个练习。练习是为ZipList' 实现Applicative，类似于Prelude 的ZipList。这本书有这个提示

检查前奏 对于可以为您提供所需的功能。一开始 与字母z，另一个与字母r。你在找 从这些函数中获取灵感，不能直接 在使用自定义 List 类型时重用它们，而不是 Prelude 提供列表类型。

我猜z开头的函数是zipWith，但我不知道以r开头的函数。

data List a =
    Nil
  | Cons a (List a)
  deriving (Eq, Show)

zipWith' :: (a -> b -> c) -> List a -> List b -> List c
zipWith' _ Nil _ = Nil
zipWith' _ _ Nil = Nil
zipWith' f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith' f xs ys)

newtype ZipList' a = ZipList' (List a)
  deriving (Eq, Show)

instance Functor ZipList' where
  fmap f (ZipList' xs) = ZipList' $ fmap f xs

instance Applicative ZipList' where
  pure x = ZipList' $ Cons x Nil
  (ZipList' fs) <*> (ZipList' xs) = ZipList' $ zipWith' ($) fs xs

这通过了书中的一个测试用例，但我想知道是否有更好的方法来实现它，因为我没有使用以r 开头的函数。我有一种感觉，这应该是 repeat，因为它也应该适用于无限列表。

Answer 1

阅读原帖下的帖子，我得出一个结论，该帖子的作者试图证明实现符合法律（fmap f xs = (pure f) <*> xs）：

让我们尝试证明它是一个经典的身份，摆脱包装。因此，让我们用右手工作：

(pure f) <*> xs = (repeat' f) <*> xs = zipWith' ($) (repeat' f) xs;

就身份而言，证明zipWith' ($) (repeat' f) xs 等于fmap f xs 就足够了。

它们相同的原因很明显：

length (zipWith op xs ys) == min (length xs) (length ys); （如果xs 和ys 都是无限的，则无法评估此表达式。

因为repeat' f 是无限的，所以length $ zipWith' ($) (repeat' f) xs 实际上是length xs（这里，这样的值是否存在实际上并不重要：索引的存在就足够了）。 xs 的每个元素都被应用到相同的函数 f 上，重复此过程。可以看到，大小被保留，每个元素都被一个常量函数变形，这就是fmap的定义。

Answer 2

Robin Zigmond's comment之后我想了想：

关键是考虑fmap f x == (pure f) <*> x对合法Applicative实例的要求，并认识到x的列表长度没有上限。

这个实现应该满足应用法则。

data List a =
    Nil
  | Cons a (List a)
  deriving (Eq, Show)

zipWith' :: (a -> b -> c) -> List a -> List b -> List c
zipWith' _ Nil _ = Nil
zipWith' _ _ Nil = Nil
zipWith' f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith' f xs ys)

repeat' :: a -> List a
repeat' x = Cons x $ repeat' x

newtype ZipList' a = ZipList' (List a)
  deriving (Eq, Show)

instance Functor ZipList' where
  fmap f (ZipList' xs) = ZipList' $ fmap f xs

instance Applicative ZipList' where
  pure x = ZipList' $ repeat' x
  (ZipList' fs) <*> (ZipList' xs) = ZipList' $ zipWith' ($) fs xs