我终于找到时间写一个通用版本。它使用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
的实例。现在让我们看一些好的输出:
*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))]
我不确定在分支顺序中会发生什么,但如果正确实现了Omega,我认为一切都应该可以解决。
但是等等!上面的实现还不完全没有bug;它在“左递归”类型上会发散,比如这个例子:
data T3 = T3 T3 | T3' deriving (Show, Generic)
虽然这个可以工作:
data T6 = T6' | T6 T6 deriving (Show, Generic)
我会尝试修复这个问题。编辑:在某个时候,这个问题的解决方案可能会在这个问题中找到。