Можно ли вообще получить принципы рекурсии?

В Идрисе есть несколько магических механизмов для автоматического создания (зависимых) элиминаторов для пользовательских типов. Мне интересно, возможно ли что-то (возможно, менее зависимое) с типами 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)

Я довольно слабо отношусь к поливарианским функциям и дженерикам, поэтому я мог бы начать с начала работы.

Ответ 1

Здесь начинается это с помощью GHC Generics. Добавление некоторого кода для повторного объединения (:+:) сделает это лучше. Требуется еще несколько экземпляров, и это, вероятно, имеет эргономические проблемы.

РЕДАКТИРОВАТЬ: Ба, я ленился и вернулся к семейству данных, чтобы получить инъективность для моей отправки равенства по типу. Это мягко изменяет интерфейс. Я подозреваю, что достаточно обмана и/или с помощью семейств инъективных типов это можно сделать без семейства данных или перекрывающихся экземпляров.

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

Ответ 2

Как заметил в комментариях к свиноводству, использование представления Generic по умолчанию приводит к большому уродству, так как у нас нет предварительной информации о рекурсии в нашем типе, и нам приходится выкапывать рекурсивные вхождения, вручную проверяя тип равенство. Я хотел бы представить здесь альтернативные решения с явной рекурсией в стиле f-алгебры. Для этого нам нужен альтернативный общий Rep. К сожалению, это означает, что мы не можем легко войти в GHC.Generics, но я надеюсь, что это все равно будет назидать.

В моем первом решении я стремлюсь к презентации, которая настолько проста, насколько это возможно в рамках существующих возможностей GHC. Второе решение - это TypeApplication - тяжелый GHC 8 с более сложными типами.

Запуск как обычно:

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

Мое общее представление является фиксированной точкой суммы продуктов. Он немного расширяет базовую модель generics-sop, которая также является суммарной продукцией, но не функториальной и поэтому плохо оборудованной для рекурсивных алгоритмов, Я думаю, что SOP в целом намного лучше практического представления, чем произвольно вложенные типы; вы можете найти расширенные аргументы в отношении того, почему это происходит в документе . Короче говоря, SOP удаляет ненужную информацию о вложенности и позволяет нам отделять метаданные от базовых данных.

Но прежде всего мы должны выбрать код для общих типов. В ваниле GHC.Generics нет четко определенного типа кодов, так как конструкторы типов сумм, продуктов и т.д. Образуют специальную грамматику уровня типа, и мы можем отправлять их с использованием классов типов. Мы более внимательно относимся к обычным представлениям в зависимых типизированных дженериках и используем явные коды, интерпретации и функции. Наши коды должны быть натуральными:

[[Maybe *]]

Внешний список кодирует сумму конструкторов, каждая внутренняя [Maybe *] кодирующая конструктор. A Just * - это просто поле конструктора, а Nothing обозначает рекурсивное поле. Например, код [Int] равен ['[], [Just Int, Nothing]].

type Rep a = Fix (SOP (Code a)) 

class Generic a where
  type Code a :: [[Maybe *]]
  to   :: a -> Rep a
  from :: Rep a -> a

data NP (ts :: [Maybe *]) (k :: *) where
  Nil  :: NP '[] k
  (:>) :: t -> NP ts k -> NP (Just t ': ts) k
  Rec  :: k -> NP ts k -> NP (Nothing ': ts) k
infixr 5 :>  

data SOP (code :: [[Maybe *]]) (k :: *) where
  Z :: NP ts k -> SOP (ts ': code) k
  S :: SOP code k -> SOP (ts ': code) k

Обратите внимание, что NP имеет разные конструкторы для рекурсивных и нерекурсивных полей. Это очень важно, потому что мы хотим, чтобы коды были однозначно отражены в индексах типа. Другими словами, мы хотели бы, чтобы NP также выступал как синглтон для [Maybe *] (хотя по веским причинам мы остаемся параметрическими по *).

Мы используем параметр k в определениях, чтобы оставить отверстие для рекурсии. Мы обычно настраиваем рекурсию, оставляя экземпляры Functor для GHC:

deriving instance Functor (SOP code)
deriving instance Functor (NP code)

newtype Fix f = In {out :: f (Fix f)}

cata :: Functor f => (f a -> a) -> Fix f -> a
cata phi = go where go = phi . fmap go . out

Имеем два типа семейств:

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, но я нахожу это слишком kludgy.

Все, что осталось, - реализовать функции:

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.

Определите некоторый сахар и экземпляры:

(<:) :: 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 (0 <: (+) <: ()) [0..10]
55

Полный код

Однако было бы лучше, если бы у нас было каррирование и не нужно было использовать HList -s или кортежи для хранения элиминаторов. Наиболее удобным способом является тот же порядок аргументов, что и в стандартных библиотечных сложениях, например foldr или maybe. В этом случае тип возврата gcata задается семейством типов, которое вычисляет из общего кода типа.

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 Fold' code a r where
  Fold' '[]         a r = r
  Fold' (ts ': tss) a r = CurryNP ts a -> Fold' tss a r

type Fold a r = Fold' (Code a) r (a -> r)

gcata :: forall a r. Generic a => Fold a r

Этот gcata сильно (полностью) неоднозначный. Нам нужно либо явное приложение, либо Proxy, и я выбрал первое, связанное с зависимостью 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

Я использовал выше частичную подпись типа в [_]. Мы также можем создать сокращение для этого:

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

который может использоваться как gcata1 @[].

Я бы предпочел не описывать реализацию вышеуказанного gcata здесь. Это не намного дольше, чем простая версия, но реализация gcata довольно волосатая (неловко, это отвечает за мой отложенный ответ). Прямо сейчас я не мог объяснить это очень хорошо, так как я написал его с помощью Agda, что влечет за собой много автоматического поиска и типа tetris.

Ответ 3

Как было сказано в комментариях и других ответах, лучше всего начать с общего представления, имеющего доступ к рекурсивным позициям.

Одна библиотека, которая работает с таким представлением, это multirec (другая - compdata):

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

Модуль FoldAlgK предоставляет сгиб с единственным типом результата и вычисляет тип алгебры как вложенную пару. Было бы относительно легко дополнительно это сделать. Существуют и другие варианты, предлагаемые библиотекой.