我试图用Haskell实现Braun树，定义如下：
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
data BraunTree (n :: Nat) a where
Empty :: BraunTree 0 a
Fork :: a -> BraunTree n a ->
BraunTree m a ->
Either (n :~: m) (n :~: (m + 1)) ->
BraunTree (n + m + 1) a
现在，我正在尝试尝试如何“类型安全”地将内容插入此树。
insert :: a -> BraunTree (n :: Nat) a -> BraunTree (n + 1 :: Nat) a
insert x Empty = Fork x Empty Empty (Left Refl)
insert x (Fork y (t1 :: BraunTree p a) (t2 :: BraunTree q a) (Left (Refl :: p :~: q))) = Fork x (t1' :: BraunTree (p + 1) a) (t2 :: BraunTree q a) (Right (sucCong Refl :: (p + 1) :~: (q + 1)))
where
t1' :: BraunTree (p + 1) a
t1' = insert x t1
sucCong为
sucCong :: ((p :: Nat) :~: (q :: Nat)) -> (p + 1 :: Nat) :~: (q + 1 :: Nat)
sucCong Refl = Refl
现在，尽管insert的第一个子句可以正常编译，但第二行引发了一个令人困惑的错误。
/home/agnishom/test/typeExp/braun.hs:31:90: error:
• Could not deduce: (((n1 + 1) + n1) + 1) ~ (n + 1)
from the context: n ~ ((n1 + m) + 1)
bound by a pattern with constructor:
Fork :: forall a (n :: Nat) (m :: Nat).
a
-> BraunTree n a
-> BraunTree m a
-> Either (n :~: m) (n :~: (m + 1))
-> BraunTree ((n + m) + 1) a,
in an equation for ‘insert’
at /home/agnishom/test/typeExp/braun.hs:31:11-85
or from: m ~ n1
bound by a pattern with constructor:
Refl :: forall k (a :: k). a :~: a,
in an equation for ‘insert’
at /home/agnishom/test/typeExp/braun.hs:31:69-72
Expected type: BraunTree (n + 1) a
Actual type: BraunTree (((n1 + 1) + m) + 1) a
NB: ‘+’ is a type function, and may not be injective
• In the expression:
Fork
x
(t1' :: BraunTree (p + 1) a)
(t2 :: BraunTree q a)
(Right (sucCong Refl :: (p + 1) :~: (q + 1)))
In an equation for ‘insert’:
insert
x
(Fork y
(t1 :: BraunTree p a)
(t2 :: BraunTree q a)
(Left (Refl :: p :~: q)))
= Fork
x
(t1' :: BraunTree (p + 1) a)
(t2 :: BraunTree q a)
(Right (sucCong Refl :: (p + 1) :~: (q + 1)))
where
t1' :: BraunTree (p + 1) a
t1' = insert x (t1 :: BraunTree p a)
• Relevant bindings include
t1' :: BraunTree (n1 + 1) a
(bound at /home/agnishom/test/typeExp/braun.hs:34:9)
t1 :: BraunTree n1 a
(bound at /home/agnishom/test/typeExp/braun.hs:31:19)
insert :: a -> BraunTree n a -> BraunTree (n + 1) a
(bound at /home/agnishom/test/typeExp/braun.hs:29:1)
我不确定我在做什么错。另外，即使我注释了t1 :: BraunTree n1 a，哈斯克尔为何仍认为t1 :: BraunTree p a（在错误消息中）？
帮助解释此错误消息将非常有帮助
答案 0 :(得分：1)
您可以尝试使用此编译器插件，该插件会自动为您推断Nat的类型相等性：
答案 1 :(得分：0)
类型签名过多。很难通读它们。另外，sucCong也不是必需的。让我们先清理一下：
insert :: a -> BraunTree n a -> BraunTree (n + 1) a
insert x Empty = Fork x Empty Empty (Left Refl)
insert x (Fork y t1 t2 (Left Refl)) = Fork x (insert x t1) t2 (Right Refl)
-- by matching on Refl ^^^^ you already prove that p ~ q
-- and (p + 1) ~ (q + 1) just follows naturally (i.e. is Refl) ^^^^
-- if you just bound the equality to a variable, then sucCong would be necessary
-- as it would match the variable to Refl "for" you.
错误是相同的
Braun.hs:#:39: error:
• Could not deduce: (((n1 + 1) + n1) + 1) ~ (n + 1)
from the context: n ~ ((n1 + m) + 1)
bound by a pattern with constructor:
Fork :: forall a (n :: Nat) (m :: Nat).
a
-> BraunTree n a
-> BraunTree m a
-> Either (n :~: m) (n :~: (m + 1))
-> BraunTree ((n + m) + 1) a,
in an equation for ‘insert’
at Braun.hs:#:11-34
or from: m ~ n1
bound by a pattern with constructor:
Refl :: forall k (a :: k). a :~: a,
in an equation for ‘insert’
at Braun.hs:#:30-33
Expected type: BraunTree (n + 1) a
Actual type: BraunTree (((n1 + 1) + m) + 1) a
NB: ‘+’ is a non-injective type family
• In the expression: Fork x (insert x t1) t2 (Right Refl)
In an equation for ‘insert’:
insert x (Fork y t1 t2 (Left Refl))
= Fork x (insert x t1) t2 (Right Refl)
• Relevant bindings include
t1 :: BraunTree n1 a (bound at Braun.hs:#:18)
insert :: a -> BraunTree n a -> BraunTree (n + 1) a
(bound at Braun.hs:#:1)
|
# | insert x (Fork y t1 t2 (Left Refl)) = Fork x (insert x t1) t2 (Right Refl)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
在消息的底部，n1是t1的索引，您将其称为p。我们还知道m（t2的索引）等于p，n（函数参数）等于(p + m) + 1。让我们将所有可能的替换应用于失败的约束：
(((n1 + 1) + n1) + 1) ~ (n + 1)
-- rename n1 to p
(((p + 1) + p) + 1) ~ (n + 1)
-- substitute n ~ (p + m) + 1
(((p + 1) + p) + 1) ~ (((p + m) + 1) + 1)
-- m ~ p
(((p + 1) + p) + 1) ~ (((p + p) + 1) + 1)
问题在于GHC无法证明((p + 1) + p) ~ ((p + p) + 1)。如果您使用了更好的Nat，它不是编译器内置的，则可以证明自己是对的。实际上，最明智的想法可能是：
{-# LANGUAGE AllowAmbiguousTypes #-}
import Unsafe.Coerce
-- using TypeApplications usually means using AllowAmbiguousTypes
-- it is also possible to use a compiler plugin to "teach" GHC the laws
-- of arithmetic
-- by keeping the unsafeCoerce in these wrappers, you decrease the chance of
-- "proving" something that isn't actually true.
plusAssoc :: forall l m r. ((l + m) + r) :~: (l + (m + r))
plusAssoc = unsafeCoerce Refl
plusComm :: forall l r. (l + r) :~: (r + l)
plusComm = unsafeCoerce Refl
insert :: a -> BraunTree n a -> BraunTree (n + 1) a
insert x Empty = Fork x Empty Empty (Left Refl)
insert x (Fork y (t1 :: BraunTree p a) t2 (Left Refl)) =
case plusAssoc @p @1 @p of Refl -> -- (p + 1) + p => p + (1 + p)
case plusComm @1 @p of Refl -> -- p + (1 + p) => p + (p + 1)
case plusAssoc @p @p @1 of Refl -> -- p + (p + 1) => (p + p) + 1
Fork x (insert x t1) t2 (Right Refl)
注意：BraunTree应该真的有两个构造函数吗？ Fork本质上有两种：平衡的和不平衡的。将Fork拆分为两个构造函数会更有意义（并删除一堆间接寻址）。这样会更好，因为您将消除某些部分定义的值。
答案 2 :(得分：0)
GHC不知道加法是可交换的和关联的。
在删除某些类型的信号后，我得到一个略有不同的错误。显然，所有相同的术语都出现了，但是顺序不同：
• Could not deduce: (((n1 + 1) + m) + 1) ~ (n + 1)
from the context: n ~ ((n1 + m) + 1)
原始方程式是等效的，但始终用m代替n1。
不幸的是，如果您坚持使用内置Nat，我不确定如何帮助GHC。我很确定您可以切换到自己的Nat，并证明必要的相等性。我不知道是否有合适的此类定理库。