All geek questions in one place

How to convince ghc that adding a level is commutative (implement an obsessive transformation)?

This does not compile because, as ghc says, adding is not injective. How do you tell the compiler that Add is indeed commutative (maybe by saying that Add is injective)? It seems from the document of Kantochism that you need to somehow provide a proxy.

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}

data Nat = Z | S Nat

type family Add a b where
  Add  Z    n = n
  Add  n    Z = n
  Add (S n) k = S (Add n k)

data VecList n a where
  Nil  :: VecList Z a
  Cons :: a -> VecList n a -> VecList (S n) a

safeRev :: forall a n . VecList n a -> VecList n a
safeRev xs = safeRevAux Nil xs
  where
    safeRevAux :: VecList p a -> VecList q a -> VecList (Add p q) a
    safeRevAux acc Nil = acc
    safeRevAux acc (Cons y ys) = safeRevAux (Cons y acc) ys

You can do this, but it seems that too much is happening under the covers for my taste.

{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}

import Data.Proxy
import Data.Type.Equality

data Nat = Z | S Nat

type family n1 + n2 where
  Z + n2 = n2
  (S n1) + n2 = S (n1 + n2)

-- singleton for Nat
data SNat :: Nat -> * where
  SZero :: SNat Z
  SSucc :: SNat n -> SNat (S n)

-- inductive proof of right-identity of +
plus_id_r :: SNat n -> ((n + Z) :~: n)
plus_id_r SZero = Refl
plus_id_r (SSucc n) = gcastWith (plus_id_r n) Refl

-- inductive proof of simplification on the rhs of +
plus_succ_r :: SNat n1 -> Proxy n2 -> ((n1 + (S n2)) :~: (S (n1 + n2)))
plus_succ_r SZero _ = Refl
plus_succ_r (SSucc n1) proxy_n2 = gcastWith (plus_succ_r n1 proxy_n2) Refl

data VecList n a where
  V0  :: VecList Z a
  Cons :: a -> VecList n a -> VecList (S n) a

reverseList :: VecList n a -> VecList n a
reverseList V0 = V0
reverseList list = go SZero V0 list
  where
    go :: SNat n1 -> VecList n1  a-> VecList n2 a -> VecList (n1 + n2) a
    go snat acc V0 = gcastWith (plus_id_r snat) acc
    go snat acc (Cons h (t :: VecList n3 a)) =
      gcastWith (plus_succ_r snat (Proxy :: Proxy n3))
              (go (SSucc snat) (Cons h acc) t)

safeHead :: VecList (S n) a -> a
safeHead (Cons x _) = x

test = safeHead $ reverseList (Cons 'a' (Cons 'b' V0))

See https://www.haskell.org/pipermail/haskell-cafe/2014-September/115919.html for the original idea.

EDIT:

@ user3237465 This is very interesting and more that I had in mind (although upon reflection my question was probably not well formulated).

I think I have "axioms"

type family n1 :+ n2 where
  Z :+ n2 = n2
  (S n1) :+ n2 = S (n1 + n2)

, ,

plus_id_r :: SNat n -> ((n + Z) :~: n)
plus_id_r SZero = Refl
plus_id_r (SSucc n) = gcastWith (plus_id_r n) Refl

. -

  • SSucc n:: SNat (S k), n:: k
  • , S k + Z: ~: S k
  • "" S k + Z = S (k + Z)
  • , S (k + Z): ~: S k
  • plus_id_r n "", (k + Z): ~: k
  • Refl "", m ~ n = > S m: ~: S n
  • , , gcast. .

""

type family n :+ m where
    Z   :+ m = m
    S n :+ m = n :+ S m

(n + Z): ~: n .

  • , SSucc x SNat (S k)
  • , S k: + Z: ~: S k
  • "" S k + Z = k + S Z
  • , k + S Z: ~: S k
  • , - , : - (

"" "" ( "" ?).

succ_plus_id :: SNat n1 -> SNat n2 -> (((S n1) :+ n2) :~: (S (n1 :+ n2)))
succ_plus_id SZero _ = Refl
succ_plus_id (SSucc n) m = gcastWith (succ_plus_id n (SSucc m)) Refl

, , , .

?

PS: ghc ,

Could not deduce ((n1 :+  'Z) ~  n1)
...
or from ((n1 :+ 'Z) ~ n1)
+4
2
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ExplicitForAll #-}

import Data.Type.Equality

data Nat = Z | S Nat

type family (n :: Nat) :+ (m :: Nat) :: Nat where
    Z   :+ m = m
    S n :+ m = n :+ S m

-- Singleton for Nat
data SNat :: Nat -> * where
  SZero :: SNat Z
  SSucc :: SNat n -> SNat (S n)

succ_plus_id :: SNat n1 -> SNat n2 -> (((S n1) :+ n2) :~: (S (n1 :+ n2)))
succ_plus_id SZero _ = Refl
succ_plus_id (SSucc n) m = gcastWith (succ_plus_id n (SSucc m)) Refl

plus_id_r :: SNat n -> ((n :+ Z) :~: n)
plus_id_r SZero = Refl
plus_id_r (SSucc x) = gcastWith (plus_id_r x) (succ_plus_id x SZero)

data Vec a n where
    Nil   :: Vec a Z
    (:::) :: a -> Vec a n -> Vec a (S n)

size :: Vec a n -> SNat n
size Nil         = SZero
size (_ ::: xs)  = SSucc $ size xs

elim0 :: SNat n -> (Vec a (n :+ Z) -> Vec a n)
elim0 n x = gcastWith (plus_id_r n) x

accrev :: Vec a n -> Vec a n
accrev x = elim0 (size x) $ go Nil x where
    go :: Vec a m -> Vec a n -> Vec a (n :+ m)
    go acc  Nil       = acc
    go acc (x ::: xs) = go (x ::: acc) xs

safeHead :: Vec a (S n) -> a
safeHead (x ::: _) = x
+4

reverse:

{-# LANGUAGE GADTs, KindSignatures, DataKinds    #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances  #-}
{-# LANGUAGE TypeOperators                       #-}

data Nat = Z | S Nat

data Vec a n where
    Nil   :: Vec a Z
    (:::) :: a -> Vec a n -> Vec a (S n)

type family n :+ m where
    Z   :+ m = m
    S n :+ m = n :+ S m

elim0 :: Vec a (n :+ Z) -> Vec a n
elim0 = undefined

accrev :: Vec a n -> Vec a n
accrev = elim0 . go Nil where
    go :: Vec a m -> Vec a n -> Vec a (n :+ m)
    go acc  Nil       = acc
    go acc (x ::: xs) = go (x ::: acc) xs

(:+) (:::). (:::) :

x ::: xs n S n. , Vec a (S n :+ m) , -, Vec a (n :+ S m).

x ::: acc         :: Vec a (S m)
xs                :: Vec a  n
go (x ::: acc) xs :: Vec a (n :+ S m)

, . elim0 :: Vec a (n :+ Z) -> Vec a n, .

Agda: http://lpaste.net/117679

, , . reverse Agda:

foldl : βˆ€ {a b} {A : Set a} (B : β„• β†’ Set b) {m} β†’
        (βˆ€ {n} β†’ B n β†’ A β†’ B (suc n)) β†’
        B zero β†’
        Vec A m β†’ B m
foldl b _βŠ•_ n []       = n
foldl b _βŠ•_ n (x ∷ xs) = foldl (Ξ» n β†’ b (suc n)) _βŠ•_ (n βŠ• x) xs

reverse : βˆ€ {a n} {A : Set a} β†’ Vec A n β†’ Vec A n
reverse {A = A} = foldl (Vec A) (Ξ» rev x β†’ x ∷ rev) []

, foldl _βŠ•_, typechecker , .

+2

Source: https://habr.com/ru/post/1569708/

More articles:


All Articles