Работа с доказательствами с участием CmpNat и синглетонов в Haskell

Я пытаюсь создать некоторые функции для работы со следующим типом. В следующем коде используются библиотеки синглетонов и ограничений на GHC-8.4.1:

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}

import Data.Constraint ((:-))
import Data.Singletons (sing)
import Data.Singletons.Prelude (Sing(SEQ, SGT, SLT), (%+), sCompare)
import Data.Singletons.Prelude.Num (PNum((+)))
import Data.Singletons.TypeLits (SNat)
import GHC.TypeLits (CmpNat, Nat)

data Foo where
  Foo
    :: forall (index :: Nat) (len :: Nat).
       (CmpNat index len ~ 'LT)
    => SNat index
    -> SNat len
    -> Foo

Это GADT, который содержит длину и индекс. Индекс гарантированно будет меньше длины.

Достаточно легко написать функцию для создания Foo:

createFoo :: Foo
createFoo = Foo (sing :: SNat 0) (sing :: SNat 1)

Однако у меня возникают проблемы при написании функции, которая увеличивает len сохраняя index тот же самый:

incrementLength :: Foo -> Foo
incrementLength (Foo index len) = Foo index (len %+ (sing :: SNat 1))

Это происходит со следующей ошибкой:

file.hs:34:34: error:
    • Could not deduce: CmpNat index (len GHC.TypeNats.+ 1) ~ 'LT
        arising from a use of ‘Foo’
      from the context: CmpNat index len ~ 'LT
        bound by a pattern with constructor:
                   Foo :: forall (index :: Nat) (len :: Nat).
                          (CmpNat index len ~ 'LT) =>
                          SNat index -> SNat len -> Foo,
                 in an equation for ‘incrementLength’
        at what5.hs:34:17-29
    • In the expression: Foo index (len %+ (sing :: SNat 1))
      In an equation for ‘incrementLength’:
          incrementLength (Foo index len)
            = Foo index (len %+ (sing :: SNat 1))
    • Relevant bindings include
        len :: SNat len (bound at what5.hs:34:27)
        index :: SNat index (bound at what5.hs:34:21)
   |
34 | incrementLength (Foo index len) = Foo index (len %+ (sing :: SNat 1))
   |                                  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Это имеет смысл, так как компилятор знает, что CmpNat index len ~ 'LT (из определения Foo), но не знает, что CmpNat index (len + 1) ~ 'LT,

Есть ли способ заставить что-то подобное работать?

Можно использовать sCompare сделать что-то вроде этого:

incrementLength :: Foo -> Foo
incrementLength (Foo index len) =
  case sCompare index (len %+ (sing :: SNat 1)) of
    SLT -> Foo index (len %+ (sing :: SNat 1))
    SEQ -> error "not eq"
    SGT -> error "not gt"

Однако, к сожалению, мне приходится писать кейсы для SEQ а также SGT, когда я знаю, что они никогда не будут сопоставлены.

Кроме того, я подумал, что возможно создать тип, подобный следующему:

plusOneLTProof :: (CmpNat n m ~ 'LT) :- (CmpNat n (m + 1) ~ 'LT)
plusOneLTProof = undefined

Однако это приводит к ошибке, подобной следующей:

file.hs:40:8: error:
    • Couldn't match type ‘CmpNat n0 m0’ with ‘CmpNat n m’
      Expected type: (CmpNat n m ~ 'LT) :- (CmpNat n (m + 1) ~ 'LT)
        Actual type: (CmpNat n0 m0 ~ 'LT) :- (CmpNat n0 (m0 + 1) ~ 'LT)
      NB: ‘CmpNat’ is a non-injective type family
      The type variables ‘n0’, ‘m0’ are ambiguous
    • In the ambiguity check for ‘bar’
      To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
      In the type signature:
        bar :: (CmpNat n m ~  'LT) :- (CmpNat n (m + 1) ~  'LT)
   |
40 | bar :: (CmpNat n m ~ 'LT) :- (CmpNat n (m + 1) ~ 'LT)
   |        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Думаю, это имеет смысл, поскольку CmpNat неинъективен. Однако я знаю, что это верно, поэтому я бы хотел написать эту функцию.


Я хотел бы получить ответ на следующие два вопроса:

  1. Есть ли способ написать incrementLength где вы должны были бы соответствовать SLT? Я бы хорошо с изменением определения Foo чтобы сделать это проще.

  2. Есть ли способ написать plusOneLTProofили хоть что то подобное?


Обновление: я закончил тем, что использовал предложение от Ли-яо Ся, чтобы написать plusOneLTProof а также incrementLength как следующее:

incrementLength :: Foo -> Foo
incrementLength (Foo index len) =
  case plusOneLTProof index len of
    Sub Dict -> Foo index (len %+ (sing :: SNat 1))

plusOneLTProof :: forall n m. SNat n -> SNat m -> (CmpNat n m ~ 'LT) :- (CmpNat n (m + 1) ~ 'LT)
plusOneLTProof SNat SNat = Sub axiom
  where
    axiom :: CmpNat n m ~ 'LT => Dict (CmpNat n (m + 1) ~ 'LT)
    axiom = unsafeCoerce (Dict :: Dict (a ~ a))

Это требует, чтобы вы прошли в два SNatс plusOneLTProof, но это не требует AllowAmbiguousTypes,

1 ответ

Решение

Компилятор отклоняет plusOneLTProof потому что его тип неоднозначен. Мы можем отключить это ограничение с расширением AllowAmbiguousTypes, Я бы порекомендовал использовать это вместе с ExplicitForall (что подразумевается под ScopedTypeVariables, что нам, безусловно, понадобится в любом случае, или RankNTypes). Это для определения этого. Определение, имеющее неоднозначный тип, может использоваться с TypeApplications,

Тем не менее, GHC до сих пор не может рассуждать о природных, поэтому мы не можем определить plusOneLTProof = Sub Dict, значительно меньше incrementLength не безопасно.

Но мы все еще можем создать доказательство из ничего unsafeCoerce, Это на самом деле, как Data.Constraint.Nat реализован модуль в ограничениях; к сожалению, в настоящее время он не содержит каких-либо фактов о CmpNat, Принуждение работает, потому что нет содержимого во время выполнения в равенствах типов. Даже если значения времени выполнения выглядят нормально, утверждение несвязных фактов может привести к неправильной работе программ.

plusOneLTProof :: forall n m. (CmpNat n m ~ 'LT) :- (CmpNat n (m+1) ~ 'LT)
plusOneLTProof = Sub axiom
  where
    axiom :: (CmpNat n m ~ 'LT) => Dict (CmpNat n (m+1) ~ 'LT)
    axiom = unsafeCoerce (Dict :: Dict (a ~ a))

Чтобы использовать доказательство, мы специализируем его (с TypeApplications) и сопоставление с образцом, чтобы представить RHS в контексте, проверяя, что LHS выполняется.

incrementLength :: Foo -> Foo
incrementLength (Foo (n :: SNat n) (m :: SNat m)) =
  case plusOneLTProof @n @m of
    Sub Dict -> Foo n (m %+ (sing :: SNat 1))
Другие вопросы по тегам