Haskell singletons : typelits package - haskell

I have a hard time convincing compiler that my types are correct. With regular
Nats with Zero and Succ constructors it is pretty straightforward (the goal is to write replicate function for length-indexed lists (Vect)):
replicate' :: SNat n -> a -> Vect n a
replicate' SZero _ = Nil
replicate' (SSucc n) a = a :> replicate' n a
But regular Nat is drastically slow.
So there is a package that mirrors GHC.TypeLits in singletons library for faster Nats.
But I can't make the above example work with it:
sameNat :: forall a b. (KnownNat a, KnownNat b) => SNat a -> SNat b -> Maybe (a :~: b)
sameNat x y
| natVal (Proxy :: Proxy a) == natVal (Proxy :: Proxy b) = Just (unsafeCoerce Refl)
| otherwise = Nothing
replicate'' :: (KnownNat n) => SNat n -> a -> Vect n a
replicate'' n a =
case sameNat n (sing :: Sing 0) of
Just Refl -> Nil
Nothing -> a ::> replicate'' (sPred n) a
This won't typecheck on last line :
Couldn't match type ‘n’
with ‘(n GHC.TypeNats.- 1) GHC.TypeNats.+ 1’

The problem is that sameNat n (sing :: Sing 0) gives you a usable n ~ 0 proof in the case that n is zero (when you pattern match on Just Refl), but if n is not zero it just gives you Nothing. That doesn't tell you anything at all about n, so as far as the type checker is aware you can call exactly the same set of things inside the Nothing branch as you could without calling sameNat in the first place (in particular, you can't use sPred because that requires that 1 <= n).
So we need to pattern match on something that either provides evidence that n ~ 0 or provides evidence that 1 <= n. Something like this:
data IsZero (n :: Nat)
where Zero :: (0 ~ n) => IsZero n
NonZero :: (1 <= n) => IsZero n
deriving instance Show (IsZero n)
Then we could write replicate'' this way:
isZero :: forall n. SNat n -> IsZero n
isZero n = _
replicate'' :: SNat n -> a -> Vect n a
replicate'' n x = case isZero n
of Zero -> Nil
NonZero -> x ::> replicate'' (sPred n) x
Of course that's just moved the problem to implementing the isZero function, which hasn't really bought us anything, but I'm going to stick with it because it's handy to have this as the basis of any other inductive definitions you want to make using Nat.
So, implementing isZero. We could handle the zero case with sameNat of course, but that doesn't help the non-zero case. The singletons package also provides Data.Singletons.Decide, which gives you a way of getting a proof of equality or inequality of types based on their singletons. So we can do this:
isZero :: forall n. SNat n -> IsZero n
isZero n = case n %~ (SNat #0)
of Proved Refl -> Zero
Disproved nonsense -> NonZero
Sadly this doesn't work either! The Proved case is fine (and the same as sameNat giving us Just Refl, basically). But the "proof of inequality" comes in the form of nonsense being bound to a function of type (n :~: 0) -> Void, and if we assume totality (without shenanigans) then the existence of such a function "proves" that we can't construct a n :~: 0 value, which proves that n definitely isn't 0. But this is just too far from a proof that 1 <= n; we can see that if n isn't 0 then it must be at least 1, from the properties of natural numbers, but GHC doesn't know this.
Another way to go would be to use singleton's Ord support and pattern match on SNat #1 :%<= n:
isZero :: forall n. SNat n -> IsZero n
isZero n = case (SNat #1) %:<= n
of STrue -> NonZero
SFalse -> Zero
But that doesn't work either, because the STrue and SFalse are just singletons for type level True and False, disconnected from the original comparison. We don't get a proof that 0 ~ n or 1 <= n from either side of this (and similarly can't get it to work by comparing with SNat #0 either). This is type-checker boolean blindness, basically.
Ultimately I was never able to satisfactorily solve this in my code. As far as I can tell we're missing a primitive; we either need to be able to compare singletons in a way that gives us < or <= constraints on the corresponding types, or we need a switch on whether a Nat is zero or nonzero.
So I cheated:
isZero :: forall n. SNat n -> IsZero n
isZero n = case n %~ (SNat #0)
of Proved Refl -> Zero
Disproved _ -> unsafeCoerce (NonZero #1)
Since NonZero only contains evidence that n is 1 or more, but not any other information about n, you can just unsafely coerce a proof that 1 is 1 or more.
Here's a full working example:
{-# LANGUAGE DataKinds
, GADTs
, KindSignatures
, ScopedTypeVariables
, StandaloneDeriving
, TypeApplications
, TypeOperators
#-}
import GHC.TypeLits ( type (<=), type (-) )
import Data.Singletons.TypeLits ( Sing (SNat), SNat, Nat )
import Data.Singletons.Prelude.Enum ( sPred )
import Data.Singletons.Decide ( SDecide ((%~))
, Decision (Proved, Disproved)
, (:~:) (Refl)
)
import Unsafe.Coerce ( unsafeCoerce )
data IsZero (n :: Nat)
where Zero :: (0 ~ n) => IsZero n
NonZero :: (1 <= n) => IsZero n
deriving instance Show (IsZero n)
isZero :: forall n. SNat n -> IsZero n
isZero n = case n %~ (SNat #0)
of Proved Refl -> Zero
Disproved _ -> unsafeCoerce (NonZero #1)
data Vect (n :: Nat) a
where Nil :: Vect 0 a
(::>) :: a -> Vect (n - 1) a -> Vect n a
deriving instance Show a => Show (Vect n a)
replicate'' :: SNat n -> a -> Vect n a
replicate'' n x = case isZero n
of Zero -> Nil
NonZero -> x ::> replicate'' (sPred n) x
head'' :: (1 <= n) => Vect n a -> a
head'' (x ::> _) = x
main :: IO ()
main = putStrLn
. (:[])
. head''
$ replicate''
(SNat #1000000000000000000000000000000000000000000000000000000)
'\x1f60e'
Note that unlike K. A. Buhr's suggested approach using unsafeCoerce, here the code for replicate is actually using the type checker to verify that it constructs a Vect n a in accordance to the SNat n provided, whereas their suggestion requires you to trust that the code does this (the actual meat of the work is done by iterate counting on Int) and only makes sure that the callers use the SNat n and the Vect n a consistently. The only bit of code you have to just trust (unchecked by the compiler) is that a Refuted _ :: Decision (n :~: 0) really does imply 1 <= n, inside isZero (which you can reuse to write lots of other functions that need to switch on whether a SNat is zero or not).
As you try to implement more functionality with your Vect, you'll find that a lot of "obvious" things GHC doesn't know about the properties of Nat are quite painful. Data.Constraint.Nat from the constraints package has a lot of useful proofs you can use (for example, if you try to implement drop :: (k <= n) => SNat k -> Vect n a -> Vect (n - k) a, you'll probably end up needing leTrans so that when you know that 1 <= k then also 1 <= n and you can actually pattern match to strip off another element). Avoiding this kind of hasochism is where K. A. Buhr's approach can be a great help, if you want to just implement your operation with code you trust and unsafeCoerce the types to line up.

As far as I can see, the exact approach you're taking can't work the way you want. sameNat is evaluated at run-time, so its "decision" isn't available to the type checker, which therefore can't perform any type inference based on differentiating between the two branches of the case construct.
You might be interested in my answer to
How to deconstruct an SNat (singletons),
regarding a similar question, which provides an implementation that avoids unsafeCoerce entirely through the use of type classes. However, as #Ben has pointed out in the comments, because of this use of type classes, the compiler has to follow a chain of n instance definitions whenever you define a vector of size n (and the compiled code may explicitly include a structure of n nested instance dictionaries) making this impractical for real code. For example, a million element vector is likely to cause the compiler to run for too long and/or use too much memory to be acceptable.
For real code, I would suggest doing the type check manually (i.e., verifying that the code, as written, is type safe) and
forcing it with unsafeCoerce:
replicate1 :: (KnownNat n) => SNat n -> a -> Vect n a
replicate1 n a =
unsafeCoerce (iterate (unsafeCoerce . (a ::>)) Nil
!! fromInteger (fromSing n))
Obviously, this definition misses the point of dependent typing for this particular definition, but the hope is that you can build up a set of trusted (manually type-checked) primitives and then build non-trivial algorithms on top of them that can benefit from more rigorous type-checking.
Note that in this particular case, you don't even really need the n parameter, so you can write:
{-# LANGUAGE ScopedTypeVariables #-}
replicate2 :: forall a n . (KnownNat n) => a -> Vect n a
replicate2 a =
unsafeCoerce (iterate (unsafeCoerce . (a ::>)) Nil
!! fromInteger (fromSing (SNat :: SNat n)))
Anyway, a full working example is:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Data.Singletons
import Data.Singletons.Prelude
import Data.Singletons.TypeLits
import Unsafe.Coerce
infixr 5 ::>
data Vect (n :: Nat) a where
Nil :: Vect 0 a
(::>) :: a -> Vect (n :- 1) a -> Vect n a
instance (Show a) => Show (Vect n a) where
showsPrec _ Nil = showString "Nil"
showsPrec d (x ::> xs) = showParen (d > prec) $
showsPrec (prec+1) x . showString " ::> " . showsPrec prec xs
where prec=5
replicate1 :: (KnownNat n) => SNat n -> a -> Vect n a
replicate1 n a =
unsafeCoerce (iterate (unsafeCoerce . (a ::>)) Nil
!! fromInteger (fromSing n))
replicate2 :: forall a n . (KnownNat n) => a -> Vect n a
replicate2 a =
unsafeCoerce (iterate (unsafeCoerce . (a ::>)) Nil
!! fromInteger (fromSing (SNat :: SNat n)))
head' :: Vect (n :+ 1) a -> a
head' (x ::> _) = x
tail' :: ((n :+ 1) :- 1) ~ n => Vect (n :+ 1) a -> Vect n a
tail' (_ ::> v) = v
main = do print (replicate2 False :: Vect 0 Bool)
print (replicate2 "Three" :: Vect 3 String)
print (head' (tail' (replicate2 "1M" :: Vect 1000000 String)))
print (replicate1 (SNat :: SNat 0) False :: Vect 0 Bool)
print (replicate1 (SNat :: SNat 3) "Three" :: Vect 3 String)
print (head' (tail' (replicate1 (SNat :: SNat 1000000) "1M" :: Vect 1000000 String)))

Related

How to convey "less than" constraint using type classes?

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))

Type-level induction on KnownNats: Overlapping instances

I'm trying to figure out how to do type-level induction on KnownNats. A toy example, summing up sized vectors from vector-sized:
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE TypeFamilies, TypeApplications, TypeOperators #-}
{-# LANGUAGE RankNTypes, DataKinds #-}
module Main where
import GHC.TypeNats
import qualified Data.Vector.Sized as V
class KnownNat d => SumVectorSized d where
sumVS :: V.Vector d Int -> Int
instance SumVectorSized 0 where
sumVS _ = 0
instance (SumVectorSized d, KnownNat d', d' ~ (1+d)) => SumVectorSized d' where
sumVS vec = V.head vec + sumVS (V.tail vec)
main = do
let Just vec = V.fromList #4 [1..4]
print $ sumVS vec
When compiled, this gives an error:
• Overlapping instances for SumVectorSized 0
arising from a use of ‘sumVS’
Matching instances:
instance SumVectorSized 0 -- Defined at src/Main.hs:14:10
instance (SumVectorSized d, KnownNat d', d' ~ (1 + d)) =>
SumVectorSized d'
-- Defined at src/Main.hs:17:10
I think the problem is that GHC doesn't know that (1+d) is not 0 for any d. How can I get across that the instances don't overlap? Or is there another way to do this kind of induction?
I think the problem is that GHC doesn't know that (1+d) is not 0 for any d.
To determine overlap, you only look to the right of =>. These overlap:
SumVectorSized 0
SumVectorSized d'
How can I get across that the instances don't overlap?
Add {-# OVERLAPPING #-} to the second instance.
Or is there another way to do this kind of induction?
This is one of many tricks to palliate the lack of dependent types in Haskell. A reasonable solution is to turn to a dependently typed language like Idris or Agda, where induction can actually be formulated as a plain function.
A less radical alternative is to go through a Peano-like singleton type:
data NatS (n :: Nat) where
ZS :: NatS 0
SS :: (n' ~ (n-1), n ~ (1 + n')) => NatS n' -> NatS n
The technique you described requires a new type class for every operation you want to perform, requiring duplication of that unsightly trick with overlapping instances. You only need one of those classes to convert a KnownNat constraint into a NatS singleton value, and then everything else is a plain function:
sumVS :: NatS n -> V.Vector n Int -> Int
sumVS ZS _ = 0
sumVS (SS n) v = V.head v + sumVS (V.tail v)
You can implement matching on KnownNats like so
matchKnownNat :: forall n r. KnownNat n => Proxy# n -> (n ~ 0 => r) -> (forall m. (KnownNat m, n ~ (1 + m)) => Proxy# m -> r) -> r
matchKnownNat n z s = case natVal' n of
0 | Refl <- (unsafeCoerce Refl :: n :~: 0) -> z
n | SomeNat (m :: Proxy m) <- someNatVal (n - 1), Refl <- (unsafeCoerce Refl :: n :~: 1 + m) -> s (proxy# #_ #m)
sumVS can be implemented in terms of this match.
sumVS :: forall n. KnownNat n => V.Vector n Int -> Int
sumVS = matchKnownNat (proxy# #_ #n) (\_ -> 0) (\_ vec -> V.head vec + sumVS (V.tail vec))
Note that it's is redundant to require KnownNat n and V.Vector n Int. All sized vectors already know their own size:
sumVS' :: forall n. V.Vector n Int -> Int
sumVS' v = V.knownLength v (sumVS v)

Proving m + (1 + n) == 1+ (m + n) in Dependent Haskell

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))

How to make fixed-length vectors instance of Applicative?

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.

Equality constraints on type level lists

I'm trying to enforce a type-level constraint that a type-level list must be the same length as a type-level Nat being carried around. For example, using Length from singletons [1] package:
data (n ~ Length ls) => NumList (n :: Nat) (ls :: [*])
test :: Proxy (NumList 2 '[Bool, String, Int])
test = Proxy
I would not expect this code to compile, since there is a mismatch.
EDIT: As dfeuer mentioned Datatype contexts aren't a good idea. I can do the comparison at the value level, but I want to be able to do this at the type level:
class NumListLen a
sameLen :: Proxy a -> Bool
instance (KnownNat n, KnownNat (Length m)) => NumListLen (NumList n m) where
sameLen = const $ (natVal (Proxy :: Proxy n)) == (natVal (Proxy :: Proxy (Length m)))
~~~~
EDIT: Sorta answered my own question, simply add the constraint to the instance:
class NumListLen a
sameLen :: Proxy a -> Bool
instance (KnownNat n, KnownNat (Length m), n ~ Length m) => NumListLen (NumList n m) where
sameLen = const $ (natVal (Proxy :: Proxy n)) == (natVal (Proxy :: Proxy (Length m)))
/home/aistis/Projects/SingTest/SingTest/app/Main.hs:333:13:
Couldn't match type ‘3’ with ‘2’
In the second argument of ‘($)’, namely ‘sameLen test’
In a stmt of a 'do' block: print $ sameLen test
In the expression:
do { print $ sameLen test;
putStrLn "done!" }
[1] https://hackage.haskell.org/package/singletons-2.0.0.2/docs/Data-Promotion-Prelude-List.html#t:Length
If this is something like an invariant (which it seems it is), you should store the proof in the datatype:
{-# LANGUAGE PolyKinds, UndecidableInstances #-}
import GHC.TypeLits
type family Length (xs :: [k]) :: Nat where
Length '[] = 0
Length (x ': xs) = 1 + Length xs
data TList n l where
TList :: (Length xs ~ n) => TList n xs
Note that while the proof is still available at the type level, it is sort of "hidden" behind the data constructor. You can recover the proof simply by pattern matching:
data (:~:) a b where Refl :: a :~: a
test :: TList n l -> Length l :~: n
test TList = Refl
Now, mismatches between the two parameters are a type error:
bad :: TList 3 '[Int, Bool]
bad = TList
good :: TList 2 '[Int, Bool]
good = TList
Of course this can still be beaten by bottom values, so
uh_oh :: TList 10 '[]
uh_oh = undefined
To avoid this, simply make sure you always pattern match on the TList constructor.
One option might be to use a type family:
data Nat = Z | S Nat
type family LengthIs (n :: Nat) (xs :: [*]) :: Bool where
LengthIs 'Z '[] = 'True
LengthIs ('S n) (x ': xs) = LengthIs n xs
LengthIs n xs = 'False
test :: LengthIs ('S ('S 'Z)) '[Bool,String,Int] ~ 'True => ()
test = ()
This will not pass the type checker; the only way to make it pass is to make the type list have two elements. I don't know how Nat works in the singletons library, but I imagine you might be able to do something similar.

Resources