Haskell 是否可以一般地导出递归原理？

在Idris中，有一些神奇的机制可以自动为用户定义的类型创建（依赖）消除器。我想知道是否有可能用Haskell类型做一些事情（也许不那么依赖）。例如，给定

data Foo a = No | Yes a | Perhaps (Foo a)

我想生成

foo :: b -> (a -> b) -> (b -> b) -> Foo a -> b
foo b _ _ No = b
foo _ f _ (Yes a) = f a
foo b f g (Perhaps c) = g (foo b f g x)

---

我在多元函数和泛型方面很弱，所以我需要一些帮助来入门。

以下是使用。添加一些代码来重新关联

（：+：）

，这样会更好。需要更多的实例，这可能有人体工程学问题

编辑：呸，我变得懒惰了，转而求助于一个数据族来获取我的类型平等分派的注入能力。这稍微改变了界面。我怀疑，如果有足够的数据族和/或使用内射类型族，这可以在没有数据族或重叠实例的情况下完成

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Main where
import Data.Function (fix)
import GHC.Generics

data Foo a = No | Yes | Perhaps (Foo a) | Extra a Int Bool
    deriving (Show, Generic1)

data Bar a = Bar (Maybe a)
    deriving (Show, Generic1)

gcata :: (GCata (f a) (Rep1 f a), Generic1 f) => Alg (f a) (Rep1 f a) r -> f a -> r
gcata f = fix(\w -> gcata' w f . from1)

ex' :: Show a => Foo a -> String
ex' = gcata (("No","Yes"),(\(Rec s) -> "Perhaps ("++s++")", \a i b -> "Extra ("++show a++") ("++show i++") ("++show b++")"))

ex1 = ex' (Perhaps (Perhaps Yes) :: Foo Int)
ex2 = ex' (Perhaps (Perhaps (Extra 'a' 2 True)) :: Foo Char)

ex3 :: Foo a -> Foo a
ex3 = gcata ((No, Yes), (Perhaps . unRec, Extra))

ex4 = gcata (\(K m) -> show m) (Bar (Just 3))

class GCata rec f where
    type Alg (rec :: *) (f :: *) (r :: *) :: *
    gcata' :: (rec -> r) -> Alg rec f r -> f -> r

instance (GCata rec (f p)) => GCata rec (M1 i c f p) where
    type Alg rec (M1 i c f p) r = Alg rec (f p) r
    gcata' w f (M1 x) = gcata' w f x

instance (GCata rec (f p), GCata rec (g p)) => GCata rec ((f :+: g) p) where
    type Alg rec ((f :+: g) p) r = (Alg rec (f p) r, Alg rec (g p) r)
    gcata' w (l,_) (L1 x) = gcata' w l x
    gcata' w (_,r) (R1 x) = gcata' w r x

instance GCata rec (U1 p) where
    type Alg rec (U1 p) r = r
    gcata' _ f U1 = f

instance (Project rec (f p), GCata rec (g p)) => GCata rec ((f :*: g) p) where
    type Alg rec ((f :*: g) p) r = Prj rec (f p) r -> Alg rec (g p) r
    gcata' w f (x :*: y) = gcata' w (f (prj w x)) y

class Project rec f where
    type Prj (rec :: *) (f :: *) (r :: *) :: *
    prj :: (rec -> r) -> f -> Prj rec f r

instance (Project rec (f p)) => Project rec (M1 i c f p) where
    type Prj rec (M1 i c f p) r = Prj rec (f p) r
    prj w (M1 x) = prj w x

instance Project rec (K1 i c p) where
    type Prj rec (K1 i c p) r = c
    prj _ (K1 x) = x

instance (RecIfEq (TEq rec (f p)) rec (f p)) => Project rec (Rec1 f p) where
    type Prj rec (Rec1 f p) r = Tgt (TEq rec (f p)) rec (f p) r
    prj w (Rec1 x) = recIfEq w x

instance Project rec (Par1 p) where
    type Prj rec (Par1 p) r = p
    prj _ (Par1 x) = x

instance GCata rec (K1 i c p) where
    type Alg rec (K1 i c p) r = c -> r
    gcata' _ f (K1 x) = f x

instance GCata rec (Par1 p) where
    type Alg rec (Par1 p) r = p -> r
    gcata' _ f (Par1 x) = f x

instance (Project rec (Rec1 f p)) => GCata rec (Rec1 f p) where
    type Alg rec (Rec1 f p) r = Prj rec (Rec1 f p) r -> r
    gcata' w f = f . prj w 

data HTrue; data HFalse

type family TEq x y where
    TEq x x = HTrue
    TEq x y = HFalse

class RecIfEq b rec t where
    data Tgt b rec t r :: *
    recIfEq :: (rec -> r) -> t -> Tgt b rec t r

instance RecIfEq HTrue rec rec where
    newtype Tgt HTrue rec rec r = Rec { unRec :: r }
    recIfEq w = Rec . w

instance RecIfEq HFalse rec t where
    newtype Tgt HFalse rec t r = K { unK :: t }
    recIfEq _ = K

---

正如pigworker在问题注释中所说，使用默认的

泛型

表示会导致非常糟糕的结果，因为我们在类型中没有关于递归的先验信息，我们必须通过手动检查类型是否相等来挖掘递归出现的情况。我想在这里介绍使用显式f-代数式递归的替代解决方案。为此，我们需要一个可选的通用

Rep

。不幸的是，这意味着我们不能轻易地利用

GHC.Generics

，但我希望这将是一个启发

在我的第一个解决方案中，我的目标是在当前GHC能力范围内进行尽可能简单的演示。第二种解决方案是

类型应用程序

——基于GHC 8的重型应用程序，具有更复杂的类型

一如往常：

{-# language
  TypeOperators, DataKinds, PolyKinds,
  RankNTypes, EmptyCase, ScopedTypeVariables,
  DeriveFunctor, StandaloneDeriving, GADTs,
  TypeFamilies, FlexibleContexts, FlexibleInstances #-}

我的泛型表示是一个乘积和的不动点。它稍微扩展了的基本模型，它也是乘积的和，但不是函数，因此不适合递归算法。我认为SOP总的来说是比任意嵌套类型更好的实用表示形式；您可以在中找到关于为什么会出现这种情况的扩展参数。简而言之，SOP删除了不必要的嵌套信息，并允许我们将元数据与基本数据分开

但在做其他事情之前，我们应该决定泛型类型的代码。在vanilla

GHC.Generics

中，没有一种定义良好的代码，因为和、积等的类型构造函数形成了一种特殊的类型级语法，我们可以使用类型类对它们进行调度。我们更严格地遵循依赖类型泛型中的常规表示，并使用显式代码、解释和函数。我们的代码应为：

[[Maybe *]]

外部列表编码一个构造函数的总和，每个内部的

[Maybe*]

编码一个构造函数。

Just*

只是一个构造函数字段，而

Nothing

表示一个递归字段。例如，

[Int]

的代码是

[']，[Just Int，Nothing]]

type Rep a=Fix（SOP（代码a））
类泛型a在哪里
类型代码a:：[[可能*]]
至：：a->代表a
from:：Rep a->a
数据NP（ts:[可能*]）（k:：*），其中
Nil:：NP'[]k
（：>）：：t->NP ts k->NP（只是t）：ts）k
记录：：k->NP ts k->NP（无）：ts）k
infixr 5:>
数据SOP（代码：：[[Maybe*]]（k:：*）其中
Z:：NP ts k->SOP（ts）：代码）k
S:：SOP代码k->SOP（ts）：代码k

注意，

NP

对于递归和非递归字段有不同的构造函数。这是非常重要的，因为我们希望代码能够明确地反映在类型索引中。换句话说，我们希望

NP

也能充当

[可能*]

的单例（尽管出于充分的理由，我们在

*

中保持参数化）

我们在定义中使用

k

参数为递归留下一个漏洞。我们像往常一样设置递归，将

Functor

实例留给GHC：

派生实例函子（SOP代码）
派生实例函子（NP代码）
newtype Fix f=In{out:：f（Fix f）}
cata:：函子f=>（fa->a）->修复f->a
cata-phi=去哪里就去哪里=phi。fmap开始。出来

我们有两种类型的族：

type family CurryNP (ts :: [Maybe *]) (r :: *) :: * where
  CurryNP '[]             r = r
  CurryNP (Just t  ': ts) r = t -> CurryNP ts r
  CurryNP (Nothing ': ts) r = r -> CurryNP ts r

type family Alg (code :: [[Maybe *]]) (r :: *) :: * where
  Alg '[]         r = ()
  Alg (ts ': tss) r = (CurryNP ts r, Alg tss r)

CurryNP ts r

curries

NP ts

，结果类型为

r

，它还插入递归出现的

r

Alg code r

计算

SOP code r

上的代数类型。它将单个构造函数的消除器组合在一起。这里我们使用简单的嵌套元组，但是当然

HList

-s也足够了。我们也可以在这里将

NP

作为

HList

重用，但我觉得这太麻烦了

剩下的就是实现以下功能：

uncurryNP :: CurryNP ts a -> NP ts a -> a
uncurryNP f Nil        = f
uncurryNP f (x :> xs)  = uncurryNP (f x) xs
uncurryNP f (Rec k xs) = uncurryNP (f k) xs

algSOP :: Alg code a -> SOP code a -> a
algSOP fs (Z np)  = uncurryNP (fst fs) np
algSOP fs (S sop) = algSOP (snd fs) sop

gcata :: Generic a => Alg (Code a) r -> a -> r
gcata f = cata (algSOP f) . to

这里的关键点是，我们必须将

Alg

中的当前消除器转换为“适当的”

SOP code a->a

代数，因为这是可以直接在

cata

中使用的形式

让我们定义一些sugar和实例：

(<:) :: a -> b -> (a, b)
(<:) = (,)
infixr 5 <:

instance Generic (Fix (SOP code)) where
  type Code (Fix (SOP code)) = code
  to   = id
  from = id  

instance Generic [a] where
  type Code [a] = ['[], [Just a, Nothing]]  
  to   = foldr (\x xs -> In (S (Z (x :> Rec xs Nil)))) (In (Z Nil))
  from = gcata ([] <: (:) <: ()) -- note the use of "Generic (Rep [a])"

此

gcata

高度（完全）不明确。我们需要显式应用程序或

代理

，而我选择了前者，导致了对GHC 8的依赖。但是，一旦我们提供了

a

类型，结果类型就会减少，我们可以很容易地实现：

> :t gcata @[_] 
gcata @[_] :: Generic [t] => r -> (t -> r -> r) -> [t] -> r
> :t gcata @[_] 0
gcata @[_] 0 :: Num t1 => (t -> t1 -> t1) -> [t] -> t1
> gcata @[_] 0 (+) [0..10]
55

我在

[\u]

中使用了上面的部分类型签名。我们还可以为此创建一个速记：

gcata1 :: forall f a r. Generic (f a) => Fold (f a) r
gcata1 = gcata @(f a) @r

它可以用作

gcata1@[]

---

我不想在这里详细说明这个问题。它并不比简单的版本长多少，但是

gcata

实现非常复杂（令人尴尬的是，它要为我延迟的回答负责）。现在我无法很好地解释它，因为我是用Agda aid编写的，它需要大量的自动搜索和键入俄罗斯方块

正如在评论和其他答案中所说的，最好从能够访问递归位置的泛型表示开始

使用这种表示的一个库是

multirec> :t gcata @[_] 
gcata @[_] :: Generic [t] => r -> (t -> r -> r) -> [t] -> r
> :t gcata @[_] 0
gcata @[_] 0 :: Num t1 => (t -> t1 -> t1) -> [t] -> t1
> gcata @[_] 0 (+) [0..10]
55

gcata1 :: forall f a r. Generic (f a) => Fold (f a) r
gcata1 = gcata @(f a) @r

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs, TypeFamilies, MultiParamTypeClasses, RankNTypes #-}
module FooFold where

import Generics.MultiRec.FoldAlgK
import Generics.MultiRec.TH

data Foo a = No | Yes a | Perhaps (Foo a)

data FooF :: * -> * -> * where
  Foo :: FooF a (Foo a)

deriveAll ''FooF

foldFoo :: (r, (a -> r, r -> r)) -> Foo a -> r
foldFoo phi = fold (const phi) Foo