Wanted to implement type safe matrix multiplication in Haskell.
Defined the following:
{-# LANGUAGE TypeFamilies, DataKinds, GADTs #-}
module Vector where
data Nat = Succ Nat | Zero
data Vector (n :: Nat) a where
Nil :: Vector 'Zero a
(:::) :: a -> Vector n a -> Vector (Succ n) a
type Matrix n m a = Vector m (Vector n a)
instance Foldable (Vector n) where
foldr f b (a ::: as) = f a (foldr f b as)
foldr _ b Nil = b
instance Functor (Vector n) where
fmap f (x ::: xs) = f x ::: fmap f xs
fmap _ Nil = Nil
zipV :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c
zipV f (a ::: as) (b ::: bs) = f a b ::: zipV f as bs
zipV f Nil Nil = Nil
Eventually had the need to implement
transpose :: Matrix n m a -> Matrix m n a
but the best I could do in Haskell was:
transpose :: Matrix n (Succ m) a -> Matrix (Succ m) n a
transpose (h ::: rest#(_ ::: _)) = zipV (:::) h (transpose rest)
transpose (h ::: Nil) = fmap (::: Nil) h
which is limited to m > 0 because I couldn't implement
nils :: {n :: Nat} -> Vector n (Vector Zero a)
Switched to Idris just to practice and did much better job:
matrix : Nat -> Nat -> Type -> Type
matrix n m a = Vector n (Vector m a)
nils : {n: Nat} -> Vector n (Vector Z a)
nils {n = Z} = Nil
nils {n = S k} = Nil ::: nils
transpose : matrix n m a -> matrix m n a
transpose (h ::: rest) = zipV (:::) h (transpose rest)
transpose Nil = nils
I have the urge to implement nils, but type level programming in Haskell is very awkward. I also had to patternmatch on rest#(_ ::: _) in Haskell, but I hadn't in Idris. How can I implement "nils"?
This is essentially what singletons are there for. That's a value-level witness for a typeclass that gives you access to this (conceptually reduntant) information that every number can in fact be described in the standard form. A minimal implementation:
data NatSing n where
ZeroSing :: NatSing Zero
SuccSing :: KnownNat n => NatSing (Succ n)
class KnownNat n where
natSing :: NatSing n
instance KnownNat Zero where natSing = ZeroSing
instance KnownNat n => KnownNat (Succ n) where natSing = SuccSing
And now it's possible to write
{-# LANGUAGE ScopedTypeVariables, UnicodeSyntax, TypeApplications #-}
nils :: ∀ n a . KnownNat n => Vector n (Vector Zero a)
nils = case natSing #n of
ZeroSing -> Nil
SuccSing -> Nil ::: nils
Related
I am trying to write a version of take that works on length-indexed vectors. This requires the number to take from to be less than or equal to the length of the vector.
This is the current version of my code:
data Nat where
Zero :: Nat
Succ :: Nat -> Nat
data SNat (n :: Nat) where
SZero :: SNat Zero
SSucc :: SNat n -> SNat (Succ n)
data Vec (n :: Nat) (a :: Type) where
Nil :: Vec Zero a
Cons :: a -> Vec n a -> Vec (Succ n) a
class (m :: Nat) >= (n :: Nat)
instance m >= Zero
instance m >= n => (Succ m >= Succ n)
take :: (m >= n) => SNat n -> Vec m a -> Vec n a
take (SZero ) _ = Nil
take (SSucc n) (x `Cons` xs) = x `Cons` (take n xs)
However, I am getting this error which I am not sure how to solve:
* Could not deduce (n2 >= n1) arising from a use of `take'
from the context: m >= n
bound by the type signature for:
take :: forall (m :: Nat) (n :: Nat) a.
(m >= n) =>
SNat n -> Vec m a -> Vec n a
at src\AnotherOne.hs:39:1-48
or from: (n :: Nat) ~ ('Succ n1 :: Nat)
bound by a pattern with constructor:
SSucc :: forall (n :: Nat). SNat n -> SNat ('Succ n),
in an equation for `take'
at src\AnotherOne.hs:41:7-13
or from: (m :: Nat) ~ ('Succ n2 :: Nat)
bound by a pattern with constructor:
Cons :: forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a,
in an equation for `take'
at src\AnotherOne.hs:41:17-27
Possible fix:
add (n2 >= n1) to the context of the data constructor `Cons'
* In the second argument of `Cons', namely `(take n xs)'
In the expression: x `Cons` (take n xs)
In an equation for `take':
take (SSucc n) (x `Cons` xs) = x `Cons` (take n xs
I have tried a few different iterations of the type class, using OVERLAPS and even INCOHERENT but I have not been able to fix it. HLS also tells me that the pattern matching is incomplete, saying that I am not matching (SSucc SZero) Nil and (SSucc (SSucc _)) Nil.
However if I try to write:
test = take (SSucc SZero) Nil
it correctly errors with Couldn't match type ‘'Zero’ with ‘'Succ 'Zero’, suggesting that my problem is specifically in the function definition, since from a few tests the API for the function seems correct.
Lastly I have been suggested to just use a type family for this, doing:
type (>=~) :: Nat -> Nat -> Bool
type family m >=~ n where
m >=~ Zero = True
Succ m >=~ Succ n = m >=~ n
_ >=~ _ = False
type m >= n = m >=~ n ~ True
Which does work, but I was trying to solve this using Haskell instances. As a side question, is there any benefit of one over the other?
The problem is that the interface of your >= class doesn't in any way express what it means for a number to be at least as great as another.
To do that, I would suggest refactoring the singleton type to clearly separate the two possible cases:
data SZero (n :: Nat) where
SZero :: SZero 'Zero
data SPositive (n :: Nat) where
SSucc :: SNat n -> SPositive ('Succ n)
type SNat n = Either (SZero n) (SPositive n)
Furthermore, we need to have a way to express rolling back the inductive steps on the type level. Here we need a type family, but it can be much simpler than your >=~ one:
type family Pred (n :: Nat) :: Nat where
Pred ('Succ n) = n
Notice this is not total! It's ok: type families can safely point to nowhere. You can still use them in a context where the compiler can infer that the clause that is there applies.
Now we can formulate the class. The crucial theorem that you noticed was missing was that in the Succ case, you can apply induction over the predecessors. More precisely, we only need to know that n is positive, in order to be able to step down the m≥n property to the predecessors of both numbers. I.e. the mathematical statement is
m≥n ∧ positive(n) ⟹ pred(m) ≥ pred(n).
We can now express exactly that, using the CPS trick to demote the implication arrow into the value-level:
class m>=n where
atLeastAsPositive :: SPositive n -> (Pred m >= Pred n => r) -> r
For the Zero case, this theorem doesn't even apply, but that's no problem – we know there aren't any suitable singletons anyway, so we can safely use an empty case match:
instance m >= 'Zero where
atLeastAsPositive s = case s of {}
The interesting case is the one of positive numbers. The way we have formulated the type, the compiler can easily connect the threads:
instance m >= n => ('Succ m >= 'Succ n) where
atLeastAsPositive (SSucc _) φ = φ
And finally, we invoke that theorem in your take function:
take :: ∀ m n a . (m >= n) => SNat n -> Vec m a -> Vec n a
take (Left SZero) _ = Nil
take (Right s#(SSucc n)) (x `Cons` xs)
= atLeastAsPositive #m s (x `Cons` (take n xs))
I am experimenting with Haskell's type system and want to write a type safe addition function. This function should accept two singleton witnesses representing numbers and returns a singleton witness of a number whose type carries the proof that it is indeed a sum of the arguments. Here is the code:
{-# language TypeFamilies, KindSignatures, DataKinds, PolyKinds, UndecidableInstances, GADTs #-}
data Nat = Zero | Succ Nat deriving Show
type family Add (m :: Nat) (n :: Nat) :: Nat where
Add Zero n = n
Add (Succ m) n = Add m (Succ n)
data SNat :: Nat -> * where
Zy :: SNat Zero
Suc :: SNat m -> SNat (Succ m)
data Bounded' m = B m
sum' :: Bounded' (SNat m) -> Bounded' (SNat n) -> Bounded' (SNat (Add m n))
sum' (B m) (B n) = B $ case (m, n) of
(Zy,x) -> x
(Suc x, y) -> let B z = sum' (B x) (B y) in Suc z
Here is the error:
• Could not deduce: Add m1 ('Succ n) ~ 'Succ (Add m1 n)
from the context: m ~ 'Succ m1
bound by a pattern with constructor:
Suc :: forall (m :: Nat). SNat m -> SNat ('Succ m),
in a case alternative
at main.hs:17:22-26
Expected type: SNat (Add m n)
Actual type: SNat ('Succ (Add m1 n))
• In the expression: Suc z
In the expression: let B z = sum' (B x) (B y) in Suc z
In a case alternative:
(Suc x, y) -> let B z = sum' (B x) (B y) in Suc z
I understand the error message. How do I provide GHC with the necessary proof that Add m n = Succ (Add k n) in expression Suc z when it learns that m ~ Succ k (in second case match) and are there alternative approaches to doing so. Thank you.
Your definition of addition is not the conventional one.
type family Add (m :: Nat) (n :: Nat) :: Nat where
Add Zero n = n
Add (Succ m) n = Add m (Succ n)
This is a "tail recursive" addition. It sure seems like there should be a way to prove your properties using this form of addition, but I can't figure it out. Until then, tail recursion at the type/property level tends to be a lot more difficult to work with than the standard kind:
type family Add (m :: Nat) (n :: Nat) :: Nat where
Add Zero n = n
Add (Succ m) n = Succ (Add m n)
This latter definition of addition makes your sum' pass without any convincing at all.
EDIT actually it was easy once I saw it right. Here's what I got (importing Data.Type.Equality and enabling LANGUAGE TypeOperators):
propSucc2 :: SNat m -> SNat n -> Add m (Succ n) :~: Succ (Add m n)
propSucc2 Zy _ = Refl
propSucc2 (Suc m) n = propSucc2 m (Suc n)
Tail-recursive definition, tail-recursive proof. Then to use it, you use gcastWith:
sum' (B m) (B n) = ...
(Suc x, y) -> gcastWith (propSucc2 x y)
(let B z = sum' (B x) (B y) in Suc z)
gcastWith just takes a :~: equality and makes it available to the type checker within the scope of its second argument.
By the way, if you define sum' in a parallel structure to your Add type family, then you don't need any lemmas. Getting things to follow parallel structures is a good technique to keep things easy (this is part of the art of dependent programming, since it's not always obvious how):
sum' :: Bounded' (SNat m) -> Bounded' (SNat n) -> Bounded' (SNat (Add m n))
sum' (B Zy) (B n) = B n
sum' (B (Suc m)) (B n) = sum' (B m) (B (Suc n))
For educational purposes, I have been trying to reconstruct an example from the book "Type-Driven Development with Idris" (namely RemoveElem.idr) in Haskell via use of various language extensions and singleton types. The gist of it is a function that removes an element from a non-empty vector, given a proof that the element is in fact in the vector. The following code is self-contained (GHC 8.4 or later). The problem appears at the very end:
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeInType #-}
import Data.Kind
import Data.Type.Equality
import Data.Void
-- | Inductively defined natural numbers.
data Nat = Z | S Nat deriving (Eq, Show)
-- | Singleton types for natural numbers.
data SNat :: Nat -> Type where
SZ :: SNat 'Z
SS :: SNat n -> SNat ('S n)
deriving instance Show (SNat n)
-- | "Demote" a singleton-typed natural number to an ordinary 'Nat'.
fromSNat :: SNat n -> Nat
fromSNat SZ = Z
fromSNat (SS n) = S (fromSNat n)
-- | A decidable proposition.
data Dec a = Yes a | No (a -> Void)
-- | Propositional equality of natural numbers.
eqSNat :: SNat a -> SNat b -> Dec (a :~: b)
eqSNat SZ SZ = Yes Refl
eqSNat SZ (SS _) = No (\case {})
eqSNat (SS _) SZ = No (\case {})
eqSNat (SS a) (SS b) = case eqSNat a b of
No f -> No (\case Refl -> f Refl)
Yes Refl -> Yes Refl
-- | A length-indexed list (aka vector).
data Vect :: Nat -> Type -> Type where
Nil :: Vect 'Z a
(:::) :: a -> Vect n a -> Vect ('S n) a
infixr 5 :::
deriving instance Show a => Show (Vect n a)
-- | #Elem a v# is the proposition that an element of type #a#
-- is contained in a vector of type #v#. To be useful, #a# and #v#
-- need to refer to singleton types.
data Elem :: forall a n. a -> Vect n a -> Type where
Here :: Elem x (x '::: xs)
There :: Elem x xs -> Elem x (y '::: xs)
deriving instance Show a => Show (Elem a v)
------------------------------------------------------------------------
-- From here on, to simplify things, only vectors of natural
-- numbers are considered.
-- | Singleton types for vectors of 'Nat's.
data SNatVect :: forall n. Nat -> Vect n Nat -> Type where
SNatNil :: SNatVect 'Z 'Nil
SNatCons :: SNat a -> SNatVect n v -> SNatVect ('S n) (a '::: v)
deriving instance Show (SNatVect n v)
-- | "Demote" a singleton-typed vector of 'SNat's to an
-- ordinary vector of 'Nat's.
fromSNatVect :: SNatVect n v -> Vect n Nat
fromSNatVect SNatNil = Nil
fromSNatVect (SNatCons a v) = fromSNat a ::: fromSNatVect v
-- | Decide whether a value is in a vector.
isElem :: SNat a -> SNatVect n v -> Dec (Elem a v)
isElem _ SNatNil = No (\case {})
isElem a (SNatCons b as) = case eqSNat a b of
Yes Refl -> Yes Here
No notHere -> case isElem a as of
Yes there -> Yes (There there)
No notThere -> No $ \case
Here -> notHere Refl
There there -> notThere there
type family RemoveElem (a :: Nat) (v :: Vect ('S n) Nat) :: Vect n Nat where
RemoveElem a (a '::: as) = as
RemoveElem a (b '::: as) = b '::: RemoveElem a as
-- | Remove a (singleton-typed) element from a (non-empty, singleton-typed)
-- vector, given a proof that the element is in the vector.
removeElem :: forall (a :: Nat) (v :: Vect ('S n) Nat)
. SNat a
-> Elem a v
-> SNatVect ('S n) v
-> SNatVect n (RemoveElem a v)
removeElem x prf (SNatCons y ys) = case prf of
Here -> ys
There later -> case ys of
SNatNil -> case later of {}
SNatCons{} -> SNatCons y (removeElem x later ys)
-- ^ Could not deduce:
-- RemoveElem a (y '::: (a2 '::: v2))
-- ~ (y '::: RemoveElem a (a2 '::: v2))
Apparently, the type system needs convincing that the types of the values x and y cannot possibly be equal in that branch of the code, so that the second equation of the type family can be used unambiguously to reduce the return type as required. I don't know how to do that. Naively, I would like the constructor There and thus the pattern match on There later to carry / reveal a proof of the type inequality to GHC.
The following is an obviously redundant and partial solution that just demonstrates the type inequality that is needed in order for GHC to type-check the recursive call:
SNatCons{} -> case (x, y) of
(SZ, SS _) -> SNatCons y (removeElem x later ys)
(SS _, SZ) -> SNatCons y (removeElem x later ys)
Now e.g. this works:
λ> let vec = SNatCons SZ (SNatCons (SS SZ) (SNatCons SZ SNatNil))
λ> :t vec
vec
:: SNatVect ('S ('S ('S 'Z))) ('Z '::: ('S 'Z '::: ('Z '::: 'Nil)))
λ> let Yes prf = isElem (SS SZ) vec
λ> :t prf
prf :: Elem ('S 'Z) ('Z '::: ('S 'Z '::: ('Z '::: 'Nil)))
λ> let vec' = removeElem (SS SZ) prf vec
λ> :t vec'
vec' :: SNatVect ('S ('S 'Z)) ('Z '::: ('Z '::: 'Nil))
λ> fromSNatVect vec'
Z ::: (Z ::: Nil)
Resolution
As hinted at in #chi's comment and elaborated in HTNW's answer, I was trying to solve the wrong problem by writing removeElem with the above type signature and type family, and if I would have been able to, the resulting program would have been ill-typed.
The following are the corrections I made based on HTNW's answer (you may want to read it before continuing here).
The first mistake, or unnecessary complication, was to repeat the length of the vector in SNatVects type. I thought it necessary in order to write fromSNatVect, but it certainly isn't:
data SNatVect (v :: Vect n Nat) :: Type where
SNatNil :: SNatVect 'Nil
SNatCons :: SNat a -> SNatVect v -> SNatVect (a '::: v)
deriving instance Show (SNatVect v)
fromSNatVect :: forall (v :: Vect n Nat). SNatVect v -> Vect n Nat
-- implementation unchanged
Now there are two approaches to writing removeElem. The first takes an Elem, an SNatVect and returns a Vect:
removeElem :: forall (a :: Nat) (n :: Nat) (v :: Vect ('S n) Nat)
. Elem a v
-> SNatVect v
-> Vect n Nat
removeElem prf (SNatCons y ys) = case prf of
Here -> fromSNatVect ys
There later -> case ys of
SNatNil -> case later of {}
SNatCons{} -> fromSNat y ::: removeElem later ys
The second takes an SElem, an SNatVect and returns an SNatVect, using a RemoveElem type family that mirrors the value-level function:
data SElem (e :: Elem a (v :: Vect n k)) where
SHere :: forall x xs. SElem ('Here :: Elem x (x '::: xs))
SThere :: forall x y xs (e :: Elem x xs). SElem e -> SElem ('There e :: Elem x (y '::: xs))
type family RemoveElem (xs :: Vect ('S n) a) (e :: Elem x xs) :: Vect n a where
RemoveElem (x '::: xs) 'Here = xs
RemoveElem (x '::: xs) ('There later) = x '::: RemoveElem xs later
sRemoveElem :: forall (xs :: Vect ('S n) Nat) (e :: Elem x xs)
. SElem e
-> SNatVect xs
-> SNatVect (RemoveElem xs e)
sRemoveElem prf (SNatCons y ys) = case prf of
SHere -> ys
SThere later -> case ys of
SNatNil -> case later of {}
SNatCons{} -> SNatCons y (sRemoveElem later ys)
Interestingly, both versions do away with passing the element to remove as a separate argument, since that information is contained in the Elem / SElem value. The value argument can also be removed from the Idris version of that function, though then the removeElem_auto variant may be a bit confusing, as it will then only have the vector as an explicit argument and remove the first element of the vector if the implicit prf argument is not explicitly used with a different proof.
Consider [1, 2, 1]. RemoveElem 1 [1, 2, 1] is [2, 1]. Now, the call removeElem 1 (There $ There $ Here) ([1, 2, 1] :: SNatVect 3 [1, 2, 1]) :: SNatVect 2 [2, 1], should compile. This is wrong. The Elem argument says to delete the third element, which would give [1, 2], but the type signature says it must be a [2, 1].
First, SNatVect is a bit broken. It has two Nat arguments:
data SNatVect :: forall n. Nat -> Vect n a -> Type where ...
The first is n, and the second is the unnamed Nat. By the structure of SNatVect, they are always equal. It allows an SNatVect to double as an equality proof, but it's probably not the intention to have it that way. You probably meant
data SNatVect (n :: Nat) :: Vect n Nat -> Type where ...
There is no way to write this signature in source Haskell using just the normal -> syntax. However, when GHC prints this type, you sometimes get
SNatVect :: forall (n :: Nat) -> Vect n Nat -> Type
But this is redundant. You can take the Nat as an implicit forall argument, and have it inferred from the Vects type:
data SNatVect (xs :: Vect n Nat) where
SNatNil :: SNatVect 'Nil
SNatCons :: SNat x -> SNatVect xs -> SNatVect (x '::: xs)
This gives
SNatVect :: forall (n :: Nat). Vect n Nat -> Type
Second, try writing
removeElem :: forall (n :: Nat) (x :: Nat) (xs :: Vect (S n) Nat).
Elem x xs -> SNatVect xs -> Vect n Nat
Note how the SNat argument is gone, and how the return type is a simple Vect. The SNat argument made the type "too big", so you got caught up making it sort of work when the function just wouldn't make sense. The SNatVect return type meant you were skipping steps. Roughly, every function has three forms: the basic one, f :: a -> b -> c; the type-level one, type family F (x :: a) (y :: b) :: c; and the dependent one, f :: forall (x :: a) (y :: b). Sing x -> Sing y -> Sing (F x y). Each is implemented in the "same" way, but trying to implement one without implementing its predecessors is a surefire way to get confused.
Now, you can lift this up a little bit:
data SElem (e :: Elem x (xs :: Vect n k)) where
SHere :: forall x xs. SElem ('Here :: Elem x (x '::: xs))
SThere :: forall x y xs (e :: Elem x xs). SElem e -> SElem ('There e :: Elem x (y '::: xs))
type family RemoveElem (xs :: Vect (S n) a) (e :: Elem x xs) :: Vect n a
Take note of the relationship between the types of removeElem and RemoveElem. The reordering of the arguments is because the type of e depends on xs, so they need to be ordered accordingly. Alternatively: the xs argument was promoted from forall'd-and-implicitly-given to explicitly-given, and then the Sing xs argument was nixed because it contained no information, due to being a singleton.
Finally, you can write this function:
sRemoveElem :: forall (xs :: Vect (S n) Nat) (e :: Elem x xs).
SElem e -> SNatVect xs -> SNatVect (RemoveElem xs e)
I recently learned about promotion and decided to try writing vectors.
{-# LANGUAGE DataKinds, GADTs, KindSignatures #-}
module Vector where
data Nat = Next Nat | Zero
data Vector :: Nat -> * -> * where
Construct :: t -> Vector n t -> Vector ('Next n) t
Empty :: Vector 'Zero t
instance Functor (Vector n) where
fmap f a =
case a of
Construct x b -> Construct (f x) (fmap f b)
Empty -> Empty
So far, everything is working. But I ran into a problem when trying to make Vector instance of Applicative.
instance Applicative (Vector n) where
a <*> b =
case a of
Construct f c ->
case b of
Construct x d -> Construct (f x) (c <*> d)
Empty -> Empty
pure x = _
I had no idea how to do pure. I tried this:
case n of
Next _ -> Construct x (pure x)
Zero -> Empty
but got Variable not in scope: n :: Nat error for the first line and Couldn't match type n with 'Zero for the third line of this expression.
So, I used the following hack.
class Applicative' n where
ap' :: Vector n (t -> u) -> Vector n t -> Vector n u
pure' :: t -> Vector n t
instance Applicative' n => Applicative' ('Next n) where
ap' (Construct f a) (Construct x b) = Construct (f x) (ap' a b)
pure' x = Construct x (pure' x)
instance Applicative' 'Zero where
ap' Empty Empty = Empty
pure' _ = Empty
instance Applicative' n => Applicative (Vector n) where
(<*>) = ap'
pure = pure'
It gets the job done, but it's not pretty. It introduces a useless class Applicative'. And every time I want to use Applicative for Vector in any function, I have to supply the additional useless constraint Applicative' n which actually holds for any n.
What would be a better, cleaner way of doing this?
You could make same directly:
instance Applicative (Vector Zero) where
a <*> b = Empty
pure x = Empty
instance Applicative (Vector n) => Applicative (Vector (Next n)) where
a <*> b =
case a of
Construct f c ->
case b of
Construct x d -> Construct (f x) (c <*> d)
pure x = Construct x (pure x)
As I can reason about it: for different types of the class, the code should be type-aware. If you had several instances, different types would get different implementation, and it would be easily resolved. But, if you try to make it with single non-recursive instance, there is basically no information about the type in runtime, and code which is always the same still needs to decide which type to handle. When you have input parameters, you can exploit GADTs to provide you the type information. But for pure there are no input parameters. So you have to have some context for the Applicative instance.
This is a (commented) alternative which exploits the singletons package.
Very roughly, Haskell does not let us pattern match on type-level values such as n in the code above. With singletons, we can, at the cost of requiring and providing a few instances of SingI here and there.
{-# LANGUAGE GADTs , KindSignatures, DataKinds, TemplateHaskell,
TypeFamilies, ScopedTypeVariables #-}
{-# OPTIONS -Wall #-}
import Data.Singletons.TH
-- Autogenerate singletons for this type
$(singletons [d|
data Nat = Next Nat | Zero
|])
-- as before
data Vector :: Nat -> * -> * where
Construct :: t -> Vector n t -> Vector ('Next n) t
Empty :: Vector 'Zero t
-- as before
instance Functor (Vector n) where
fmap _ Empty = Empty
fmap f (Construct x b) = Construct (f x) (fmap f b)
-- We now require n to carry its own SingI instance.
-- This allows us to pattern match on n.
instance SingI n => Applicative (Vector n) where
Empty <*> Empty = Empty
-- Here, we need to access the singleton on n, so that later on we
-- can provide the SingI (n-1) instance we need for the recursive call.
-- The withSingI allows us to use m :: SNat (n-1) to provide the instance.
(Construct f c) <*> (Construct x d) = case sing :: SNat n of
SNext m -> withSingI m $ Construct (f x) (c <*> d)
-- Here, we can finally pattern match on n.
-- As above, we need to provide the instance with withSingI
-- to the recursive call.
pure x = case sing :: SNat n of
SZero -> Empty
SNext m -> withSingI m $ Construct x (pure x)
Using this will require to provide a SingI n instance at every use, which is a bit inconvenient, but not too much (IMO). The sad part is that <*> does not really need SingI n, since, in principle, it could recompute that from the two vectors at hand. However, pure has no input vector, so it can only pattern match with a provided singleton.
As another alternative, similar to the original code, one could write
instance Applicative (Vector Zero) where
...
instance Applicative (Vector n) => Applicative (Vector (Next n)) where
...
This is not completely equivalent, and will require to add contexts Applicative (Vector n) => in all the functions later on where n is unknown, but could be enough for many purposes.
Consider this an addendum to #chi's answer to provide additional explanation of the singleton approach...
I would suggest reading the Hasochism paper if you haven't already done so. In particular, in section 3.1 of that paper, they deal with exactly this problem, and use it as the motivating example for when implicit singleton parameters (the SingI of #chi's answer, and the NATTY type class in the Hasochism paper) are necessary, rather than merely convenient.
As it applies to your code, the main issue is that pure needs a run-time representation of the length of the vector that it's supposed to be generating, and the type-level variable n doesn't fit the bill. The solution is to introduce a new GADT, a "singleton" that provides runtime values that correspond directly to the promoted types Next and Zero:
data Natty (n :: Nat) where
ZeroTy :: Natty Zero
NextTy :: Natty n -> Natty (Next n)
I tried to use roughly the same naming convention as the paper: Natty is the same, and ZeroTy and NextTy correspond to the paper's Zy and Sy.
By itself, this explicit singleton is useful. For example, see the definition of vchop in the paper. Also, we can easily write a variant of pure that takes the explicit singleton to do its job:
vcopies :: Natty n -> a -> Vector n a
vcopies ZeroTy _ = Empty
vcopies (NextTy n) x = Construct x (vcopies n x)
We can't yet use this to define pure, though, because pure's signature is determined by the Applicative type class, and we have no way to squeeze the explicit singleton Natty n in there.
The solution is to introduce implicit singletons, which allow us to retrieve an explicit singleton whenever needed through the natty function in the context of the following type class:
class NATTY n where
natty :: Natty n
instance NATTY Zero where
natty = ZeroTy
instance NATTY n => NATTY (Next n) where
natty = NextTy natty
Now, provided we're in a NATTY n context, we can call vcopies natty to supply vcopies with its explicit natty parameter, which allows us to write:
instance NATTY n => Applicative (Vector n) where
(<*>) = vapp
pure = vcopies natty
using the definitions of vcopies and natty above, and the definition of vapp below:
vapp :: Vector n (a -> b) -> Vector n a -> Vector n b
vapp Empty Empty = Empty
vapp (Construct f c) (Construct x d) = Construct (f x) (vapp c d)
Note one oddity. We needed to introduce this vapp helper function for an obscure reason. The following instance without NATTY matches your case-based definition and type-checks fine:
instance Applicative (Vector n) where
Empty <*> Empty = Empty
Construct f c <*> Construct x d = Construct (f x) (c <*> d)
pure = error "Argh! No NATTY!"
If we add the NATTY constraint to define pure:
instance NATTY n => Applicative (Vector n) where
Empty <*> Empty = Empty
Construct f c <*> Construct x d = Construct (f x) (c <*> d)
pure = vcopies natty
the definition of (<*>) doesn't type check any more. The problem is that the NATTY n constraint on the left-hand side of the second (<*>) case doesn't automatically imply a NATTY n1 constraint on the right-hand side (where Next n ~ n1), so GHC doesn't want to allow us to call (<*>) on the right-hand side. In this case, because the constraint isn't actually needed after it's used for the first time, a helper function without a NATTY constraint, namely vapp, works around the problem.
#chi uses case matching on natty and the helper function withSingI as an alternative workaround. The equivalent code here would use a helper function that turns an explicit singleton into an implicit NATTY context:
withNATTY :: Natty n -> (NATTY n => a) -> a
withNATTY ZeroTy a = a
withNATTY (NextTy n) a = withNATTY n a
allowing us to write:
instance NATTY n => Applicative (Vector n) where
Empty <*> Empty = Empty
Construct f c <*> Construct x d = case (natty :: Natty n) of
NextTy n -> withNATTY n $ Construct (f x) (c <*> d)
pure x = case (natty :: Natty n) of
ZeroTy -> Empty
NextTy n -> Construct x (withNATTY n $ pure x)
This would need both ScopedTypeVariables and RankNTypes.
Anyway, sticking with the helper functions, the complete program looks like this:
{-# LANGUAGE DataKinds, GADTs, KindSignatures #-}
module Vector where
data Nat = Next Nat | Zero
data Vector :: Nat -> * -> * where
Construct :: t -> Vector n t -> Vector ('Next n) t
Empty :: Vector 'Zero t
data Natty (n :: Nat) where
ZeroTy :: Natty Zero
NextTy :: Natty n -> Natty (Next n)
class NATTY n where
natty :: Natty n
instance NATTY Zero where
natty = ZeroTy
instance NATTY n => NATTY (Next n) where
natty = NextTy natty
instance Functor (Vector n) where
fmap f a =
case a of
Construct x b -> Construct (f x) (fmap f b)
Empty -> Empty
instance NATTY n => Applicative (Vector n) where
(<*>) = vapp
pure = vcopies natty
vapp :: Vector n (a -> b) -> Vector n a -> Vector n b
vapp Empty Empty = Empty
vapp (Construct f c) (Construct x d) = Construct (f x) (vapp c d)
vcopies :: Natty n -> a -> Vector n a
vcopies ZeroTy _ = Empty
vcopies (NextTy n) x = Construct x (vcopies n x)
The correspondence with the singletons library is that:
$(singletons [d|
data Nat = Next Nat | Zero
|])
automatically generates the singletons (with constructors SZero and SNat instead of ZeroTy and NatTy; and with type SNat instead of Natty) and the implicit singleton class (called SingI instead of NATTY and using the function sing instead of natty), giving the complete program:
{-# LANGUAGE DataKinds, GADTs, KindSignatures, TemplateHaskell, TypeFamilies #-}
module Vector where
import Data.Singletons
import Data.Singletons.TH
$(singletons [d|
data Nat = Next Nat | Zero
|])
data Vector :: Nat -> * -> * where
Construct :: t -> Vector n t -> Vector ('Next n) t
Empty :: Vector 'Zero t
instance Functor (Vector n) where
fmap f a =
case a of
Construct x b -> Construct (f x) (fmap f b)
Empty -> Empty
instance SingI n => Applicative (Vector n) where
(<*>) = vapp
pure = vcopies sing
vapp :: Vector n (a -> b) -> Vector n a -> Vector n b
vapp Empty Empty = Empty
vapp (Construct f c) (Construct x d) = Construct (f x) (vapp c d)
vcopies :: SNat n -> a -> Vector n a
vcopies SZero _ = Empty
vcopies (SNext n) x = Construct x (vcopies n x)
For more on what the singletons library does and how it's built, I'd suggest reading Introduction to Singletons.
Several other answers have introduced a Natty or SNat type to implement pure. Indeed, having such a type greatly reduces the need for one-off type classes. A potential downside of the traditional Natty/SNat GADT, however, is that your program will actually build the representation and then use it, even if the Nat is known at compile time. This generally wouldn't happen with the auxiliary-class approach. You can get around this by using a different representation.
I'm going to use these names:
data Nat = Z | S Nat
Suppose we define the usual
data Natty n where
Zy :: Natty 'Z
Sy :: Natty n -> Natty ('S n)
We can write its eliminator (induction principle) thus:
natty :: p 'Z -> (forall k. p k -> p ('S k)) -> Natty n -> p n
natty z _ Zy = z
natty z s (Sy n) = s (natty z s n)
For our purpose, we don't really need the Natty; we only need its induction principle! So let's define another version. I imagine there's a proper name for this encoding, but I have no idea what it might be.
newtype NatC n = NatC
{ unNatC :: forall p.
p 'Z -- base case
-> (forall k. p k -> p ('S k)) -- inductive step
-> p n }
This is isomorphic to Natty:
nattyToNatC :: Natty n -> NatC n
nattyToNatC n = NatC (\z s -> natty z s n)
natCToNatty :: NatC n -> Natty n
natCToNatty (NatC f) = f Zy Sy
Now we can write a class for Nats we know how to eliminate:
class KnownC n where
knownC :: NatC n
instance KnownC 'Z where
knownC = NatC $ \z _ -> z
instance KnownC n => KnownC ('S n) where
knownC = NatC $ \z s -> s $ unNatC knownC z s
Now here's a vector type (I've renamed things to match my own taste):
infixr 4 :<
data Vec :: Nat -> * -> * where
(:<) :: t -> Vec n t -> Vec ('S n) t
Nil :: Vec 'Z t
Because Vec's length parameter isn't its last one, we'll have to flip it to use with NatC:
newtype Flip f a n = {unFlip :: f n a}
induct2 :: f 'Z a
-> (forall k. f k a -> f ('S k) a)
-> NatC n -> f n a
induct2 z s n = unFlip $ unNatC n (Flip z) (\(Flip r) -> Flip (s r))
replC :: NatC n -> a -> Vec n a
replC n a = induct2 Nil (a :<) n
instance KnownC n => Applicative (Vec n) where
pure = replC knownC
(<*>) = ...
Now if the vector length is known at compile time, the pure vector will be built directly, with no intermediate structure needed.
I have a type level numbers
data Z deriving Typeable
data S n deriving Typeable
and n-ary functions (code from fixed-vector package)
-- | Type family for n-ary functions.
type family Fn n a b
type instance Fn Z a b = b
type instance Fn (S n) a b = a -> Fn n a b
-- | Newtype wrapper which is used to make 'Fn' injective. It's also a
-- reader monad.
newtype Fun n a b = Fun { unFun :: Fn n a b }
I need function like
uncurryN :: Fun (n + k) a b -> Fun n a (Fun k a b)
I read several articles about type level computations, but all about type safe list concatenation.
This required a bit of care in unwrapping/rewrapping the Fun newtype. I also exploited the DataKinds extension.
{-# LANGUAGE DataKinds, KindSignatures, TypeFamilies,
MultiParamTypeClasses, ScopedTypeVariables, FlexibleInstances #-}
{-# OPTIONS -Wall #-}
-- | Type-level naturals.
data Nat = Z | S Nat
-- | Type family for n-ary functions.
type family Fn (n :: Nat) a b
type instance Fn Z a b = b
type instance Fn (S n) a b = a -> Fn n a b
-- | Addition.
type family Add (n :: Nat) (m :: Nat) :: Nat
type instance Add Z m = m
type instance Add (S n) m = S (Add n m)
-- | Newtype wrapper which is used to make 'Fn' injective.
newtype Fun n a b = Fun { unFun :: Fn n a b }
class UncurryN (n :: Nat) (m :: Nat) a b where
uncurryN :: Fun (Add n m) a b -> Fun n a (Fun m a b)
instance UncurryN Z m a b where
uncurryN g = Fun g
instance UncurryN n m a b => UncurryN (S n) m a b where
uncurryN g = Fun (\x -> unFun (uncurryN (Fun (unFun g x)) :: Fun n a (Fun m a b)))
{- An expanded equivalent with more signatures:
instance UncurryN n m a b => UncurryN (S n) m a b where
uncurryN g = let f :: a -> Fn n a (Fun m a b)
f x = let h :: Fun (Add n m) a b
h = Fun ((unFun g :: Fn (Add (S n) m) a b) x)
in unFun (uncurryN h :: Fun n a (Fun m a b))
in Fun f
-}
You can do this without any type classes by constructing a datatype which can represent the type Nat on the data level:
data Nat = Z | S Nat
type family Fn (n :: Nat) a b
type instance Fn Z a b = b
type instance Fn (S n) a b = a -> Fn n a b
type family Add (n :: Nat) (m :: Nat) :: Nat
type instance Add Z m = m
type instance Add (S n) m = S (Add n m)
newtype Fun n a b = Fun { unFun :: Fn n a b }
data SNat (n :: Nat) where
SZ :: SNat Z
SS :: SNat n -> SNat (S n)
uncurryN :: forall n m a b . SNat n -> Fun (Add n m) a b -> Fun n a (Fun m a b)
uncurryN SZ f = Fun f
uncurryN (SS (n :: SNat n')) g = Fun (\x -> unFun (uncurryN n (Fun (unFun g x)) :: Fun n' a (Fun m a b)))
If you don't like explicitly mentioning the n parameter, thats ok since you can always go back and forth between a function which takes an parameter as a type class and which takes a parameter as data:
class SingI (a :: k) where
type Sing :: k -> *
sing :: Sing a
instance SingI Z where
type Sing = SNat
sing = SZ
instance SingI n => SingI (S n) where
type Sing = SNat
sing = SS sing
toNatSing :: (SNat n -> t) -> (SingI n => t)
toNatSing f = f sing
fromNatSing :: (SingI n => t) -> (SNat n -> t)
fromNatSing f SZ = f
fromNatSing f (SS n) = fromNatSing f n
uncurryN' :: SingI n => Fun (Add n m) a b -> Fun n a (Fun m a b)
uncurryN' = toNatSing uncurryN