如何枚举Haskell中的递归数据类型？

Question

这篇博文有一个有趣的解释,说明如何使用Omega monad对角枚举任意语法.他提供了一个如何操作的示例,从而产生无限的字符串序列.我想做同样的事情,除了生成一个实际数据类型列表,而不是生成字符串列表.例如,

 data T = A | B T | C T T

会生成

A, B A, C A A, C (B A) A... 

或类似的东西.不幸的是,我的Haskell技能仍在成熟,经过几个小时的演奏后,我无法做到我想要的.怎么办？

根据要求,我的一次尝试(我尝试了太多东西......):

import Control.Monad.Omega

data T = A | B T | C T T deriving (Show)

a = [A] 
        ++ (do { x <- each a; return (B x) })
        ++ (do { x <- each a; y <- each a; return (C x y) })

main = print $ take 10 $ a

Answer 1

我的第一个丑陋的方法是:

allTerms :: Omega T
allTerms = do
  which <- each [ 1,2,3 ]
  if which == 1 then
    return A
  else if which == 2 then do
    x <- allTerms
    return $ B x
  else do
    x <- allTerms
    y <- allTerms
    return $ C x y

但是,经过一些清理后,我到达了这一个班轮

import Control.Applicative
import Control.Monad.Omega
import Control.Monad

allTerms :: Omega T
allTerms = join $ each [return A, B <$> allTerms, C <$> allTerms <*> allTerms]

请注意,订单很重要:return A必须是上面列表中的第一个选择,或者allTerms不会终止.基本上,Omegamonad确保选项之间的"公平调度",从而节省您,例如infiniteList ++ something,但不会阻止无限递归.

Crazy FIZRUK提出了一个更优雅的解决方案,利用了这个 Alternative实例Omega.

import Control.Applicative
import Data.Foldable (asum)
import Control.Monad.Omega

allTerms :: Omega T
allTerms = asum [ pure A
                , B <$> allTerms
                , C <$> allTerms <*> allTerms
                ]

Answer 2

我终于找到了编写通用版本的时间.它使用Universe类型类,它表示递归的可枚举类型.这里是:

{-# LANGUAGE DeriveGeneric, TypeOperators, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances, OverlappingInstances #-}

import Data.Universe
import Control.Monad.Omega
import GHC.Generics
import Control.Monad (mplus, liftM2)

class GUniverse f where
    guniverse :: [f a]

instance GUniverse U1 where
    guniverse = [U1]

instance (Universe c) => GUniverse (K1 i c) where
    guniverse = fmap K1 (universe :: [c])

instance (GUniverse f) => GUniverse (M1 i c f) where
    guniverse = fmap M1 (guniverse :: [f p])

instance (GUniverse f, GUniverse g) => GUniverse (f :*: g) where
    guniverse = runOmega $ liftM2 (:*:) ls rs
        where ls = each (guniverse :: [f p])
              rs = each (guniverse :: [g p])

instance (GUniverse f, GUniverse g) => GUniverse (f :+: g) where
    guniverse = runOmega $ (fmap L1 $ ls) `mplus` (fmap R1 $ rs)
        where ls = each (guniverse :: [f p])
              rs = each (guniverse :: [g p])

instance (Generic a, GUniverse (Rep a)) => Universe a where
    universe = fmap to $ (guniverse :: [Rep a x])


data T = A | B T | C T T deriving (Show, Generic)
data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving (Show, Generic)

我找不到一种方法可以删除UndecidableInstances,但这应该没有更大的关注.OverlappingInstances只需要覆盖预定义的Universe实例,比如Either's.现在一些不错的输出:

*Main> take 10 $ (universe :: [T])
[A,B A,B (B A),C A A,B (B (B A)),C A (B A),B (C A A),C (B A) A,B (B (B (B A))),C A (B (B A))]
*Main> take 20 $ (universe :: [Either Int Char])
[Left (-9223372036854775808),Right '\NUL',Left (-9223372036854775807),Right '\SOH',Left (-9223372036854775806),Right '\STX',Left (-9223372036854775805),Right '\ETX',Left (-9223372036854775804),Right '\EOT',Left (-9223372036854775803),Right '\ENQ',Left (-9223372036854775802),Right '\ACK',Left (-9223372036854775801),Right '\a',Left (-9223372036854775800),Right '\b',Left (-9223372036854775799),Right '\t']
*Main> take 10 $ (universe :: [Tree Bool])
[Leaf False,Leaf True,Branch (Leaf False) (Leaf False),Branch (Leaf False) (Leaf True),Branch (Leaf True) (Leaf False),Branch (Leaf False) (Branch (Leaf False) (Leaf False)),Branch (Leaf True) (Leaf True),Branch (Branch (Leaf False) (Leaf False)) (Leaf False),Branch (Leaf False) (Branch (Leaf False) (Leaf True)),Branch (Leaf True) (Branch (Leaf False) (Leaf False))]

我不完全确定在分支顺序中会发生什么mplus,但我认为如果Omega正确实现它应该都能解决,我坚信.

可是等等!上面的实现还没有错误; 它在"左递归"类型上有所不同,如下所示:

data T3 = T3 T3 | T3' deriving (Show, Generic)

虽然这有效:

data T6 = T6' | T6 T6 deriving (Show, Generic)

我会看看能不能解决这个问题.编辑:在某个时候,这个问题的解决方案可能会在这个问题中找到.