从 Haskell 中的一组选项中选择 managing/representing 的模式
Patterns for managing/representing selection from a set of options in Haskell
代数数据类型使得从一组中选择一个项目变得容易：只需使用适当的求和类型。
我很好奇如何实现从集合中严格选择 n 项或更少项的选项。我可以看到如何使用 Data.Set 来实现它，但我想知道是否存在更稳健的模式或代数结构。
假设一个汉堡可以有三种来自泡菜集合的配料 |洋葱 |生菜 | Tomato 等。想要在 UI 中显示所有选项是合理的，所以如果我们使用 Data.Set，我马上注意到 Data.Set.all 丢失了，所以没有简单的方法打印所有可以选择的值。但是 Data.Set.powerSet 可用，所以我想也许我应该让用户选择基数 <= 3.
的幂集子集中的一个元素
使用幂集的元素来表示从基集中进行的选择似乎是个好主意。不过，它看起来不像我能想到的任何 UI。幂集函子是一个 monad，但我不确定这是否相关（请参阅此处关于幂集作为函子的讨论 Sets, Functors and Eq confusion）。
也许以前解决过类似问题的人会对如何最好地完成这项工作提出建议。我真的在寻找关于“n 选择 k”类型的概念性见解，如果这有意义的话。
这是一个答案。
下面是其余代码所需的一些扩展和导入。
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import GHC.TypeNats
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as Set
您可能已经知道，将单个项目表示为 ADT 的好处是：
data Topping = Pickle | Onion | Lettuce | Tomato deriving (Show, Eq, Ord, Enum, Bounded)
是类型的定义使得除了 Topping 的一个选择之外不可能表示任何东西，前提是我们忽略了 undefined 值的可能性。使用 Maybe 类型以这种万无一失的方式表示“最多选择 Topping”同样容易：
type UpToOneTopping = Maybe Topping
我们还可以使用列表表示零个或多个（可能包括无限数量的）浇头，可能有重复：
type ManyToppings = [Topping]
但是，很难以同样的方式表示一组没有重复的浇头。我们可以使用 Set Topping 类型，但我们不再依赖类型系统来使具有重复项的集合无法表示。相反，我们依赖于 containers 包中 Set 类型的实现，以及它提供的受限接口，以保证该集合不包含任何重复项。如果我们深入研究 Set 实现的核心，我们可能会发现内部表示可以允许重复的集合，并且我们依赖于 Set 作者编写的代码的正确性以确保这不会发生。
相比之下，上面的 Topping 类型提供了比这更强的保证，使得除了单一类型之外的任何东西都无法通过构造来表示。 （好吧，我想你可以说我们依赖于编译器的正确性，但通常认为这种保证比依赖 Set 实现的正确性的保证“更强”。）
与 Set 类型类似，可以使用 UpToThree Topping 类型来表示一组零到三个不同的浇头，但保证将由实现及其认可的接口，而不是数据表示本身。也就是说，我们可以这样写：
newtype UpToThree a = UpToThree (Set a)
upToThree :: (Ord a) => [a] -> UpToThree a
upToThree xs | length xs' > 3 = error "no more than three allowed"
| otherwise = UpToThree xs'
where xs' = Set.fromList xs
如果我们仅通过此 upToThree“智能构造函数”创建 UpToThree 值（通过程序员纪律或使用 Haskell 的包系统来限制导出给用户的接口数据类型），那么我们可以提供某种保证，即任何 UpToThree 值将代表不超过三个不同的 a 值。
在实际的 Haskell 代码中，这可能是最合理的方法。一个限制是它需要为每个 up-to-k 数字创建一个单独的新类型。我们可以使数字成为数据类型中的一个字段：
data UpToK a = UpToK Int (Set a)
upToK :: (Ord a) => Int -> [a] -> UpToK a
upToK k xs | length xs' > k = error "too many"
| otherwise = UpToK k xs'
where xs' = Set.fromList xs
但是这种 UpToK 类型的用处远不如它最初看起来的那么有用。问题是智能构造函数确保一个特定的 UpToK 代表许多不同的 a 类型的值，这些值不超过值中编码的整数字段 k 给出的计数，所以它确保了值中两个字段之间的一致性，但是类型系统不强制执行任何关于 k 的内容，所以如果我们有一个函数，使用原始 UpToThree 需要不超过三个浇头:
data Burger = Burger
placeOnBurger :: UpToThree Topping -> Burger
placeOnBurger u = undefined
我们可以通过使用 UpToThree 的类型签名来确保我们收到的浇头不超过三个，前提是 UpToThree 类型的实现是合理的，但是如果我们尝试编写一个 UpToK 版本，我们最终不得不检查该字段以确保满足我们的先决条件：
placeOnBurger' :: UpToK Topping -> Burger
placeOnBurger' (UpToK k _) | k > 3 = error "no one can fit so many toppings!"
placeOnBurger' u = undefined
这意味着我们可以直接检查 Set 的长度，根本不需要 UpToK 类型：
placeOnBurger'' :: Set Topping -> Burger
placeOnBurger'' s | length s > 3 = error "too many toppings for a burger"
placeOnBurger'' s = undefined
幸运的是，有一种方法可以使用 DataKinds 扩展，通过非负数索引类型集合。通过一些其他扩展，这允许我们写：
newtype UpTo (k :: Nat) a = UpTo (Set a)
upTo :: forall k a. (KnownNat k, Ord a) => [a] -> UpTo k a
upTo xs | length xs' > fromIntegral (natVal (Proxy @k)) = error "too many"
| otherwise = UpTo xs'
where xs' = Set.fromList xs
这个 UpTo 类型比 UpToK 有用得多。它仍然依赖于受保护的 upTo 智能构造函数来确保只生成有效的 UpTo 值，但是上限现在是类型的一部分，所以我们可以写：
placeOnBurger''' :: UpTo 3 Topping -> Burger
placeOnBurger''' s = undefined
并且我们有一个强大的类型系统保证 placeOnBurger''' 的这个版本只会用 UpTo 3 Topping 值调用，这意味着（较弱的）智能构造函数保证浇头的数量passed 不会超过三个。
如果您希望对类型中的上限进行编码以使其由类型系统本身强制执行，以同样的方式 Maybe Topping 强制执行零或一的上限规则，那么这是可能的, 但它很快就会变得笨重。
一种方法是将 GADT 与由 DataKinds 扩展名自动提升到类型级别的 Peano natural 结合使用：
data Peano = Z | S Peano
使用类型级函数将普通类型级自然值转换为这些 Peano 类型级自然值也很有帮助：
type family P n where
P 0 = Z
P n = S (P (n-1))
然后我们可以很容易地创建一个 GADT 来表示“不超过 n”个元素的列表：
-- a list of no more than `n` elements of type `a`
data LimitedList (n :: Peano) a where
Empty :: LimitedList n a
Cons :: a -> LimitedList n a -> LimitedList (S n) a
infixr 5 `Cons`
deriving instance (Show a) => Show (LimitedList n a)
需要稍微研究一下才能理解为什么这种表示有效，但是观察当我们尝试创建一个类型级别限制为 3、5 和 2 的 3 元素列表时 GHCi 中会发生什么：
λ> 1 `Cons` 2 `Cons` 3 `Cons` Empty :: LimitedList (P 3) Int
...works...
λ> 1 `Cons` 2 `Cons` 3 `Cons` Empty :: LimitedList (P 5) Int
...works...
λ> 1 `Cons` 2 `Cons` 3 `Cons` Empty :: LimitedList (P 2) Int
...generates a type error...
这个 GADT 的缺点是它允许重复并且不提供唯一的表示，所以如果我们有泡菜和洋葱的多种表示作为不超过 3 种浇头的列表：
top1 = Pickle `Cons` Onion `Cons` Empty :: LimitedList (P 3) Topping
top2 = Onion `Cons` Pickle `Cons` Empty :: LimitedList (P 3) Topping
top3 = Onion `Cons` Pickle `Cons` Onion `Cons` Empty :: LimitedList (P 3) Topping
但希望它们被统一对待（比较相等，当我们对它们进行 运行 toList 时以相同的顺序生成相同的浇头列表，等等），我们将结束不得不编写更多代码来提供这些（弱）保证。
要回答您问题的另一部分，可以编写一个函数来为任何可枚举类型生成特定大小的所有有效 LimitedList，尽管输出将包括这些重复项和替代表示形式。编写这样的函数需要使用所谓的 Peano naturals 的“单例”表示：
data SPeano n where
SZ :: SPeano Z
SS :: SPeano n -> SPeano (S n)
allLimitedLists :: (Enum a, Bounded a) => SPeano n -> [LimitedList n a]
allLimitedLists SZ = [Empty]
allLimitedLists (SS n) = [x `Cons` xs | x <- [minBound..maxBound]
, xs <- rest]
++ map levelUp rest
where rest = allLimitedLists n
levelUp :: LimitedList n a -> LimitedList (S n) a
levelUp Empty = Empty
levelUp (x `Cons` xs) = x `Cons` levelUp xs
all3Toppings :: [LimitedList (P 3) Topping]
all3Toppings = allLimitedLists (SS (SS (SS SZ)))
main = print all3Toppings
这里相当奇怪的 levelUp 函数是一个昂贵的身份函数，至少在术语级别。 （在类型级别，它不是身份，这才是重点。）无论如何，它是 LimitedList 表示选择的不幸产物。具有讽刺意味的是，它可以安全地替换为 levelUp = unsafeCoerce。至少，我认为可以。无论如何，它似乎有效。
在我给出最后一种方法之前，这是目前为止的所有代码，以防您想使用它：
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import GHC.TypeNats
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as Set
data Topping = Pickle | Onion | Lettuce | Tomato deriving (Show, Eq, Ord, Enum, Bounded)
type UpToOneTopping = Maybe Topping
type ManyToppings = [Topping]
newtype UpToThree a = UpToThree (Set a)
upToThree :: (Ord a) => [a] -> UpToThree a
upToThree xs | length xs' > 3 = error "no more than three allowed"
| otherwise = UpToThree xs'
where xs' = Set.fromList xs
data UpToK a = UpToK Int (Set a)
upToK :: (Ord a) => Int -> [a] -> UpToK a
upToK k xs | length xs' > k = error "too many"
| otherwise = UpToK k xs'
where xs' = Set.fromList xs
data Burger = Burger
placeOnBurger :: UpToThree Topping -> Burger
placeOnBurger u = undefined
placeOnBurger' :: UpToK Topping -> Burger
placeOnBurger' (UpToK k _) | k > 3 = error "no one can fit so many toppings!"
placeOnBurger' u = undefined
placeOnBurger'' :: Set Topping -> Burger
placeOnBurger'' s | length s > 3 = error "too many toppings for a burger"
placeOnBurger'' s = undefined
newtype UpTo (k :: Nat) a = UpTo (Set a)
upTo :: forall k a. (KnownNat k, Ord a) => [a] -> UpTo k a
upTo xs | length xs' > fromIntegral (natVal (Proxy @k)) = error "too many"
| otherwise = UpTo xs'
where xs' = Set.fromList xs
placeOnBurger''' :: UpTo 3 Topping -> Burger
placeOnBurger''' s = undefined
data Peano = Z | S Peano
type family P n where
P 0 = Z
P n = S (P (n-1))
-- a list of no more than `n` elements of type `a`
data LimitedList (n :: Peano) a where
Empty :: LimitedList n a
Cons :: a -> LimitedList n a -> LimitedList (S n) a
infixr 5 `Cons`
deriving instance (Show a) => Show (LimitedList n a)
top1 = Pickle `Cons` Onion `Cons` Empty :: LimitedList (P 3) Topping
top2 = Onion `Cons` Pickle `Cons` Empty :: LimitedList (P 3) Topping
top3 = Onion `Cons` Pickle `Cons` Onion `Cons` Empty :: LimitedList (P 3) Topping
data SPeano n where
SZ :: SPeano Z
SS :: SPeano n -> SPeano (S n)
allLimitedLists :: (Enum a, Bounded a) => SPeano n -> [LimitedList n a]
allLimitedLists SZ = [Empty]
allLimitedLists (SS n) = [x `Cons` xs | x <- [minBound..maxBound]
, xs <- rest]
++ map levelUp rest
where rest = allLimitedLists n
levelUp :: LimitedList n a -> LimitedList (S n) a
levelUp Empty = Empty
levelUp (x `Cons` xs) = x `Cons` levelUp xs
all3Toppings :: [LimitedList (P 3) Topping]
all3Toppings = allLimitedLists (SS (SS (SS SZ)))
main = print all3Toppings
最后，可以在类型级别强制执行唯一的、无重复的表示，但它增加了另一层复杂性并使类型 much 更难使用。这是一种方法，它通过对类型中的最小元素进行编码并使用约束来允许只添加较小的元素。我已经使用 singletons 包来处理一些样板文件，因此我们需要相当多的扩展和一些导入：
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Singletons
import Data.Singletons.Prelude
import Data.Singletons.TH
我们的 Peano naturals 和 Topping 类型都需要单例，如下所示。
$(singletons [d|
data Peano = Z | S Peano
data Topping = Pickle | Onion | Lettuce | Tomato deriving (Show, Eq, Ord, Enum, Bounded)
|])
这里，我们使用promote来定义类型函数P和Before。这些可以使用类型族来定义，但是提升普通 Haskell 函数可以提供更好的语法。
$(promote [d|
p 0 = Z
p n = S (p (n-1))
before _ Nothing = True
before x (Just y) = x < y
|])
我们的有限集将由以下 GADT 表示，它表示 a 类型元素的（严格）升序列表，其头部（最小）元素为 h，并且不包含超过 n 个元素。我们在这里使用 Before 类型函数来允许将 x 值添加到列表中，前提是它严格小于列表的头元素。
data MinLimitedSet (n :: Peano) (h :: Maybe a) where
Empty' :: MinLimitedSet n Nothing
Cons' :: (Before x min ~ True) => Sing x -> MinLimitedSet n min -> MinLimitedSet (S n) (Just x)
infixr 5 `Cons'`
在代码中使用此 MinLimitedSet 类型需要在类型签名中指定列表的最小元素。这不是很方便，所以我们提供了一个存在类型 LimitedSet 表示一个 MinLimitedSet 具有未指定的最小元素：
data LimitedSet (n :: Peano) a where
LimitedSet :: MinLimitedSet n (h :: Maybe a) -> LimitedSet n a
有了这些 GADT，我们可以定义一个示例值：
top1' :: LimitedSet (P 3) Topping
top1' = LimitedSet $ sing @Pickle `Cons'` sing @Onion `Cons'` Empty'
请注意，此定义仅有效，因为 Pickle 和 Onion 严格按升序排列（根据 Topping 的 Ord 实例）并且没有组合了三个以上的元素。如果您尝试创建一个包含太多配料的列表，或者一个包含重复项或不按严格升序排列的列表，您将收到编译时类型错误。要在程序中使用此类列表，您通常需要将它们转换为普通的术语级列表，这就是 toList 函数所做的。
toList :: forall n a. (SingKind a) => LimitedSet n a -> [Demote a]
toList (LimitedSet asc) = go asc
where go :: forall n lst. MinLimitedSet n lst -> [Demote a]
go (Empty') = []
go (x `Cons'` xs) = fromSing x : go xs
main = print $ toList top1'
完整代码：
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Singletons
import Data.Singletons.Prelude
import Data.Singletons.TH
$(singletons [d|
data Peano = Z | S Peano
data Topping = Pickle | Onion | Lettuce | Tomato deriving (Show, Eq, Ord, Enum, Bounded)
|])
$(promote [d|
p 0 = Z
p n = S (p (n-1))
before _ Nothing = True
before x (Just y) = x < y
|])
data MinLimitedSet (n :: Peano) (h :: Maybe a) where
Empty' :: MinLimitedSet n Nothing
Cons' :: (Before x min ~ True) => Sing x -> MinLimitedSet n min -> MinLimitedSet (S n) (Just x)
infixr 5 `Cons'`
data LimitedSet (n :: Peano) a where
LimitedSet :: MinLimitedSet n (h :: Maybe a) -> LimitedSet n a
top1' :: LimitedSet (P 3) Topping
top1' = LimitedSet $ sing @Pickle `Cons'` sing @Onion `Cons'` Empty'
toList :: forall n a. (SingKind a) => LimitedSet n a -> [Demote a]
toList (LimitedSet asc) = go asc
where go :: forall n lst. MinLimitedSet n lst -> [Demote a]
go (Empty') = []
go (x `Cons'` xs) = fromSing x : go xs
main = print $ toList top1'
代数数据类型使得从一组中选择一个项目变得容易：只需使用适当的求和类型。
我很好奇如何实现从集合中严格选择 n 项或更少项的选项。我可以看到如何使用 Data.Set 来实现它，但我想知道是否存在更稳健的模式或代数结构。
假设一个汉堡可以有三种来自泡菜集合的配料 |洋葱 |生菜 | Tomato 等。想要在 UI 中显示所有选项是合理的，所以如果我们使用 Data.Set，我马上注意到 Data.Set.all 丢失了，所以没有简单的方法打印所有可以选择的值。但是 Data.Set.powerSet 可用，所以我想也许我应该让用户选择基数 <= 3.
的幂集子集中的一个元素使用幂集的元素来表示从基集中进行的选择似乎是个好主意。不过，它看起来不像我能想到的任何 UI。幂集函子是一个 monad，但我不确定这是否相关（请参阅此处关于幂集作为函子的讨论 Sets, Functors and Eq confusion）。
也许以前解决过类似问题的人会对如何最好地完成这项工作提出建议。我真的在寻找关于“n 选择 k”类型的概念性见解，如果这有意义的话。
这是一个答案。
下面是其余代码所需的一些扩展和导入。
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import GHC.TypeNats
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as Set
您可能已经知道，将单个项目表示为 ADT 的好处是：
data Topping = Pickle | Onion | Lettuce | Tomato deriving (Show, Eq, Ord, Enum, Bounded)
是类型的定义使得除了 Topping 的一个选择之外不可能表示任何东西，前提是我们忽略了 undefined 值的可能性。使用 Maybe 类型以这种万无一失的方式表示“最多选择 Topping”同样容易：
type UpToOneTopping = Maybe Topping
我们还可以使用列表表示零个或多个（可能包括无限数量的）浇头，可能有重复：
type ManyToppings = [Topping]
但是，很难以同样的方式表示一组没有重复的浇头。我们可以使用 Set Topping 类型，但我们不再依赖类型系统来使具有重复项的集合无法表示。相反，我们依赖于 containers 包中 Set 类型的实现，以及它提供的受限接口，以保证该集合不包含任何重复项。如果我们深入研究 Set 实现的核心，我们可能会发现内部表示可以允许重复的集合，并且我们依赖于 Set 作者编写的代码的正确性以确保这不会发生。
相比之下，上面的 Topping 类型提供了比这更强的保证，使得除了单一类型之外的任何东西都无法通过构造来表示。 （好吧，我想你可以说我们依赖于编译器的正确性，但通常认为这种保证比依赖 Set 实现的正确性的保证“更强”。）
与 Set 类型类似，可以使用 UpToThree Topping 类型来表示一组零到三个不同的浇头，但保证将由实现及其认可的接口，而不是数据表示本身。也就是说，我们可以这样写：
newtype UpToThree a = UpToThree (Set a)
upToThree :: (Ord a) => [a] -> UpToThree a
upToThree xs | length xs' > 3 = error "no more than three allowed"
| otherwise = UpToThree xs'
where xs' = Set.fromList xs
如果我们仅通过此 upToThree“智能构造函数”创建 UpToThree 值（通过程序员纪律或使用 Haskell 的包系统来限制导出给用户的接口数据类型），那么我们可以提供某种保证，即任何 UpToThree 值将代表不超过三个不同的 a 值。
在实际的 Haskell 代码中，这可能是最合理的方法。一个限制是它需要为每个 up-to-k 数字创建一个单独的新类型。我们可以使数字成为数据类型中的一个字段：
data UpToK a = UpToK Int (Set a)
upToK :: (Ord a) => Int -> [a] -> UpToK a
upToK k xs | length xs' > k = error "too many"
| otherwise = UpToK k xs'
where xs' = Set.fromList xs
但是这种 UpToK 类型的用处远不如它最初看起来的那么有用。问题是智能构造函数确保一个特定的 UpToK 代表许多不同的 a 类型的值，这些值不超过值中编码的整数字段 k 给出的计数，所以它确保了值中两个字段之间的一致性，但是类型系统不强制执行任何关于 k 的内容，所以如果我们有一个函数，使用原始 UpToThree 需要不超过三个浇头:
data Burger = Burger
placeOnBurger :: UpToThree Topping -> Burger
placeOnBurger u = undefined
我们可以通过使用 UpToThree 的类型签名来确保我们收到的浇头不超过三个，前提是 UpToThree 类型的实现是合理的，但是如果我们尝试编写一个 UpToK 版本，我们最终不得不检查该字段以确保满足我们的先决条件：
placeOnBurger' :: UpToK Topping -> Burger
placeOnBurger' (UpToK k _) | k > 3 = error "no one can fit so many toppings!"
placeOnBurger' u = undefined
这意味着我们可以直接检查 Set 的长度，根本不需要 UpToK 类型：
placeOnBurger'' :: Set Topping -> Burger
placeOnBurger'' s | length s > 3 = error "too many toppings for a burger"
placeOnBurger'' s = undefined
幸运的是，有一种方法可以使用 DataKinds 扩展，通过非负数索引类型集合。通过一些其他扩展，这允许我们写：
newtype UpTo (k :: Nat) a = UpTo (Set a)
upTo :: forall k a. (KnownNat k, Ord a) => [a] -> UpTo k a
upTo xs | length xs' > fromIntegral (natVal (Proxy @k)) = error "too many"
| otherwise = UpTo xs'
where xs' = Set.fromList xs
这个 UpTo 类型比 UpToK 有用得多。它仍然依赖于受保护的 upTo 智能构造函数来确保只生成有效的 UpTo 值，但是上限现在是类型的一部分，所以我们可以写：
placeOnBurger''' :: UpTo 3 Topping -> Burger
placeOnBurger''' s = undefined
并且我们有一个强大的类型系统保证 placeOnBurger''' 的这个版本只会用 UpTo 3 Topping 值调用，这意味着（较弱的）智能构造函数保证浇头的数量passed 不会超过三个。
如果您希望对类型中的上限进行编码以使其由类型系统本身强制执行，以同样的方式 Maybe Topping 强制执行零或一的上限规则，那么这是可能的, 但它很快就会变得笨重。
一种方法是将 GADT 与由 DataKinds 扩展名自动提升到类型级别的 Peano natural 结合使用：
data Peano = Z | S Peano
使用类型级函数将普通类型级自然值转换为这些 Peano 类型级自然值也很有帮助：
type family P n where
P 0 = Z
P n = S (P (n-1))
然后我们可以很容易地创建一个 GADT 来表示“不超过 n”个元素的列表：
-- a list of no more than `n` elements of type `a`
data LimitedList (n :: Peano) a where
Empty :: LimitedList n a
Cons :: a -> LimitedList n a -> LimitedList (S n) a
infixr 5 `Cons`
deriving instance (Show a) => Show (LimitedList n a)
需要稍微研究一下才能理解为什么这种表示有效，但是观察当我们尝试创建一个类型级别限制为 3、5 和 2 的 3 元素列表时 GHCi 中会发生什么：
λ> 1 `Cons` 2 `Cons` 3 `Cons` Empty :: LimitedList (P 3) Int
...works...
λ> 1 `Cons` 2 `Cons` 3 `Cons` Empty :: LimitedList (P 5) Int
...works...
λ> 1 `Cons` 2 `Cons` 3 `Cons` Empty :: LimitedList (P 2) Int
...generates a type error...
这个 GADT 的缺点是它允许重复并且不提供唯一的表示，所以如果我们有泡菜和洋葱的多种表示作为不超过 3 种浇头的列表：
top1 = Pickle `Cons` Onion `Cons` Empty :: LimitedList (P 3) Topping
top2 = Onion `Cons` Pickle `Cons` Empty :: LimitedList (P 3) Topping
top3 = Onion `Cons` Pickle `Cons` Onion `Cons` Empty :: LimitedList (P 3) Topping
但希望它们被统一对待（比较相等，当我们对它们进行 运行 toList 时以相同的顺序生成相同的浇头列表，等等），我们将结束不得不编写更多代码来提供这些（弱）保证。
要回答您问题的另一部分，可以编写一个函数来为任何可枚举类型生成特定大小的所有有效 LimitedList，尽管输出将包括这些重复项和替代表示形式。编写这样的函数需要使用所谓的 Peano naturals 的“单例”表示：
data SPeano n where
SZ :: SPeano Z
SS :: SPeano n -> SPeano (S n)
allLimitedLists :: (Enum a, Bounded a) => SPeano n -> [LimitedList n a]
allLimitedLists SZ = [Empty]
allLimitedLists (SS n) = [x `Cons` xs | x <- [minBound..maxBound]
, xs <- rest]
++ map levelUp rest
where rest = allLimitedLists n
levelUp :: LimitedList n a -> LimitedList (S n) a
levelUp Empty = Empty
levelUp (x `Cons` xs) = x `Cons` levelUp xs
all3Toppings :: [LimitedList (P 3) Topping]
all3Toppings = allLimitedLists (SS (SS (SS SZ)))
main = print all3Toppings
这里相当奇怪的 levelUp 函数是一个昂贵的身份函数，至少在术语级别。 （在类型级别，它不是身份，这才是重点。）无论如何，它是 LimitedList 表示选择的不幸产物。具有讽刺意味的是，它可以安全地替换为 levelUp = unsafeCoerce。至少，我认为可以。无论如何，它似乎有效。
在我给出最后一种方法之前，这是目前为止的所有代码，以防您想使用它：
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import GHC.TypeNats
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as Set
data Topping = Pickle | Onion | Lettuce | Tomato deriving (Show, Eq, Ord, Enum, Bounded)
type UpToOneTopping = Maybe Topping
type ManyToppings = [Topping]
newtype UpToThree a = UpToThree (Set a)
upToThree :: (Ord a) => [a] -> UpToThree a
upToThree xs | length xs' > 3 = error "no more than three allowed"
| otherwise = UpToThree xs'
where xs' = Set.fromList xs
data UpToK a = UpToK Int (Set a)
upToK :: (Ord a) => Int -> [a] -> UpToK a
upToK k xs | length xs' > k = error "too many"
| otherwise = UpToK k xs'
where xs' = Set.fromList xs
data Burger = Burger
placeOnBurger :: UpToThree Topping -> Burger
placeOnBurger u = undefined
placeOnBurger' :: UpToK Topping -> Burger
placeOnBurger' (UpToK k _) | k > 3 = error "no one can fit so many toppings!"
placeOnBurger' u = undefined
placeOnBurger'' :: Set Topping -> Burger
placeOnBurger'' s | length s > 3 = error "too many toppings for a burger"
placeOnBurger'' s = undefined
newtype UpTo (k :: Nat) a = UpTo (Set a)
upTo :: forall k a. (KnownNat k, Ord a) => [a] -> UpTo k a
upTo xs | length xs' > fromIntegral (natVal (Proxy @k)) = error "too many"
| otherwise = UpTo xs'
where xs' = Set.fromList xs
placeOnBurger''' :: UpTo 3 Topping -> Burger
placeOnBurger''' s = undefined
data Peano = Z | S Peano
type family P n where
P 0 = Z
P n = S (P (n-1))
-- a list of no more than `n` elements of type `a`
data LimitedList (n :: Peano) a where
Empty :: LimitedList n a
Cons :: a -> LimitedList n a -> LimitedList (S n) a
infixr 5 `Cons`
deriving instance (Show a) => Show (LimitedList n a)
top1 = Pickle `Cons` Onion `Cons` Empty :: LimitedList (P 3) Topping
top2 = Onion `Cons` Pickle `Cons` Empty :: LimitedList (P 3) Topping
top3 = Onion `Cons` Pickle `Cons` Onion `Cons` Empty :: LimitedList (P 3) Topping
data SPeano n where
SZ :: SPeano Z
SS :: SPeano n -> SPeano (S n)
allLimitedLists :: (Enum a, Bounded a) => SPeano n -> [LimitedList n a]
allLimitedLists SZ = [Empty]
allLimitedLists (SS n) = [x `Cons` xs | x <- [minBound..maxBound]
, xs <- rest]
++ map levelUp rest
where rest = allLimitedLists n
levelUp :: LimitedList n a -> LimitedList (S n) a
levelUp Empty = Empty
levelUp (x `Cons` xs) = x `Cons` levelUp xs
all3Toppings :: [LimitedList (P 3) Topping]
all3Toppings = allLimitedLists (SS (SS (SS SZ)))
main = print all3Toppings
最后，可以在类型级别强制执行唯一的、无重复的表示，但它增加了另一层复杂性并使类型 much 更难使用。这是一种方法，它通过对类型中的最小元素进行编码并使用约束来允许只添加较小的元素。我已经使用 singletons 包来处理一些样板文件，因此我们需要相当多的扩展和一些导入：
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Singletons
import Data.Singletons.Prelude
import Data.Singletons.TH
我们的 Peano naturals 和 Topping 类型都需要单例，如下所示。
$(singletons [d|
data Peano = Z | S Peano
data Topping = Pickle | Onion | Lettuce | Tomato deriving (Show, Eq, Ord, Enum, Bounded)
|])
这里，我们使用promote来定义类型函数P和Before。这些可以使用类型族来定义，但是提升普通 Haskell 函数可以提供更好的语法。
$(promote [d|
p 0 = Z
p n = S (p (n-1))
before _ Nothing = True
before x (Just y) = x < y
|])
我们的有限集将由以下 GADT 表示，它表示 a 类型元素的（严格）升序列表，其头部（最小）元素为 h，并且不包含超过 n 个元素。我们在这里使用 Before 类型函数来允许将 x 值添加到列表中，前提是它严格小于列表的头元素。
data MinLimitedSet (n :: Peano) (h :: Maybe a) where
Empty' :: MinLimitedSet n Nothing
Cons' :: (Before x min ~ True) => Sing x -> MinLimitedSet n min -> MinLimitedSet (S n) (Just x)
infixr 5 `Cons'`
在代码中使用此 MinLimitedSet 类型需要在类型签名中指定列表的最小元素。这不是很方便，所以我们提供了一个存在类型 LimitedSet 表示一个 MinLimitedSet 具有未指定的最小元素：
data LimitedSet (n :: Peano) a where
LimitedSet :: MinLimitedSet n (h :: Maybe a) -> LimitedSet n a
有了这些 GADT，我们可以定义一个示例值：
top1' :: LimitedSet (P 3) Topping
top1' = LimitedSet $ sing @Pickle `Cons'` sing @Onion `Cons'` Empty'
请注意，此定义仅有效，因为 Pickle 和 Onion 严格按升序排列（根据 Topping 的 Ord 实例）并且没有组合了三个以上的元素。如果您尝试创建一个包含太多配料的列表，或者一个包含重复项或不按严格升序排列的列表，您将收到编译时类型错误。要在程序中使用此类列表，您通常需要将它们转换为普通的术语级列表，这就是 toList 函数所做的。
toList :: forall n a. (SingKind a) => LimitedSet n a -> [Demote a]
toList (LimitedSet asc) = go asc
where go :: forall n lst. MinLimitedSet n lst -> [Demote a]
go (Empty') = []
go (x `Cons'` xs) = fromSing x : go xs
main = print $ toList top1'
完整代码：
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Singletons
import Data.Singletons.Prelude
import Data.Singletons.TH
$(singletons [d|
data Peano = Z | S Peano
data Topping = Pickle | Onion | Lettuce | Tomato deriving (Show, Eq, Ord, Enum, Bounded)
|])
$(promote [d|
p 0 = Z
p n = S (p (n-1))
before _ Nothing = True
before x (Just y) = x < y
|])
data MinLimitedSet (n :: Peano) (h :: Maybe a) where
Empty' :: MinLimitedSet n Nothing
Cons' :: (Before x min ~ True) => Sing x -> MinLimitedSet n min -> MinLimitedSet (S n) (Just x)
infixr 5 `Cons'`
data LimitedSet (n :: Peano) a where
LimitedSet :: MinLimitedSet n (h :: Maybe a) -> LimitedSet n a
top1' :: LimitedSet (P 3) Topping
top1' = LimitedSet $ sing @Pickle `Cons'` sing @Onion `Cons'` Empty'
toList :: forall n a. (SingKind a) => LimitedSet n a -> [Demote a]
toList (LimitedSet asc) = go asc
where go :: forall n lst. MinLimitedSet n lst -> [Demote a]
go (Empty') = []
go (x `Cons'` xs) = fromSing x : go xs
main = print $ toList top1'