How to deconstruct an SNat (singletons) - haskell

I am experimenting with depedent types in Haskell and came across the following in the paper of the 'singletons' package:
replicate2 :: forall n a. SingI n => a -> Vec a n
replicate2 a = case (sing :: Sing n) of
SZero -> VNil
SSucc _ -> VCons a (replicate2 a)
So I tried to implement this myself, just toget a feel of how it works:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Data.Singletons
import Data.Singletons.Prelude
import Data.Singletons.TypeLits
data V :: Nat -> * -> * where
Nil :: V 0 a
(:>) :: a -> V n a -> V (n :+ 1) a
infixr 5 :>
replicateV :: SingI n => a -> V n a
replicateV = replicateV' sing
where replicateV' :: Sing n -> a -> V n a
replicateV' sn a = case sn of
SNat -> undefined -- what can I do with this?
Now the problem is that the Sing instance for Nat does not have SZero or SSucc. There is only one constructor called SNat.
> :info Sing
data instance Sing n where
SNat :: KnownNat n => Sing n
This is different than other singletons that allow matching, such as STrue and SFalse, such as in the following (useless) example:
data Foo :: Bool -> * -> * where
T :: a -> Foo True a
F :: a -> Foo False a
foo :: forall a b. SingI b => a -> Foo b a
foo a = case (sing :: Sing b) of
STrue -> T a
SFalse -> F a
You can use fromSing to get a base type, but this of course does allow GHC to check the type of the output vector:
-- does not typecheck
replicateV2 :: SingI n => a -> V n a
replicateV2 = replicateV' sing
where replicateV' :: Sing n -> a -> V n a
replicateV' sn a = case fromSing sn of
0 -> Nil
n -> a :> replicateV2 a
So my question: how to implement replicateV?
EDIT
The answer given by erisco explains why my approach of deconstructing an SNat does not work. But even with the type-natural library, I am unable to implement replicateV for the V data type using GHC's build-in Nat types.
For example the following code compiles:
replicateV :: SingI n => a -> V n a
replicateV = replicateV' sing
where replicateV' :: Sing n -> a -> V n a
replicateV' sn a = case TN.sToPeano sn of
TN.SZ -> undefined
(TN.SS sn') -> undefined
But this does not seem to give enough information to the compiler to infer whether n is 0 or not. For example the following gives a compiler error:
replicateV :: SingI n => a -> V n a
replicateV = replicateV' sing
where replicateV' :: Sing n -> a -> V n a
replicateV' sn a = case TN.sToPeano sn of
TN.SZ -> Nil
(TN.SS sn') -> undefined
This gives the following error:
src/Vec.hs:25:28: error:
• Could not deduce: n1 ~ 0
from the context: TN.ToPeano n1 ~ 'TN.Z
bound by a pattern with constructor:
TN.SZ :: forall (z0 :: TN.Nat). z0 ~ 'TN.Z => Sing z0,
in a case alternative
at src/Vec.hs:25:13-17
‘n1’ is a rigid type variable bound by
the type signature for:
replicateV' :: forall (n1 :: Nat) a1. Sing n1 -> a1 -> V n1 a1
at src/Vec.hs:23:24
Expected type: V n1 a1
Actual type: V 0 a1
• In the expression: Nil
In a case alternative: TN.SZ -> Nil
In the expression:
case TN.sToPeano sn of {
TN.SZ -> Nil
(TN.SS sn') -> undefined }
• Relevant bindings include
sn :: Sing n1 (bound at src/Vec.hs:24:21)
replicateV' :: Sing n1 -> a1 -> V n1 a1 (bound at src/Vec.hs:24:9)
So, my original problem still remains, I am still unable to do anything usefull with the SNat.

There are two notions of naturals at play here. One is "literal naturals" (i.e. 0, 1, 2, and so on) and the other is "Peano naturals" (i.e. Z, S Z, S (S Z), and so on). The one the paper is using is clearly Peano naturals but the one singletons uses is literal naturals.
Thankfully there is another package called type-natural which defines Peano naturals as well as conversion to literal naturals and conversion from literal naturals.

From the comments, I'm worried I must be missing something terrifically obvious, but here's my take on it. The whole point of:
replicate2 :: forall n a. SingI n => a -> Vec a n
replicate2 a = case (sing :: Sing n) of
SZero -> VNil
SSucc _ -> VCons a (replicate2 a)
is that, in order to return VNil :: Vec a 0 when the function has general return type Vec a n, you need to specialize the n to 0, and pattern-matching on GADTs provides a way to do this, as long as you have a constructor, like SZero, that implies n ~ 0.
Now the SNats in the singleton package have no such constructor. The only way to get one, as far as I can see, is to build a whole new singleton type for naturals and implement the necessary type families. Maybe you can do it in a way that wraps the Nats, so you're closer to SZero :: Sing (SN 0), SNonZero :: Sing (SN n) than a Peano construction, but I don't know.
Of course, there's another way to specialize a function that returns Vec a n to return Vec a 0, namely type classes.
If you are willing to abandon some of the explicit singleton machinery and switch to type classes (and also allow overlapping and undecidable instances), the following seems to work. I had to slightly modify the definition of V to use n :- 1 instead of n :+ 1, but I don't think that poses a problem.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Singletons
import Data.Singletons.Prelude
import Data.Singletons.TypeLits
data V :: Nat -> * -> * where
Nil :: V 0 a
(:>) :: a -> V (n :- 1) a -> V n a
infixr 5 :>
class VC n a where
replicateV :: a -> V n a
instance VC 0 a where
replicateV _ = Nil
instance VC (n :- 1) a => VC n a where
replicateV x = x :> replicateV x
instance (Show a) => Show (V n a) where
show Nil = "Nil"
show (x :> v) = show x ++ " :> " ++ show v
headV :: V (n :+ 1) a -> a
headV (x :> _) = x
tailV :: ((n :+ 1) :- 1) ~ n => V (n :+ 1) a -> V n a
tailV (_ :> v) = v
main = do print (replicateV False :: V 0 Bool)
print (replicateV 1 :: V 1 Int)
print (replicateV "Three" :: V 3 String)

Related

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)

Is posible to create an infinite wrapper in Haskell with Rank N types?

I tried this experiment:
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
wrapper :: forall a (b :: * -> *). Monad b => Int -> a -> b a
wrapper 1 v = return v
wrapper n v = return $ wrapper (n-1) v
But it gives to me the error:
Occurs check: cannot construct the infinite type: a ~ b0 a
Expected type: b a
Actual type: b (b0 a)
• In the expression: return $ wrapper (n - 1) v
In an equation for ‘wrapper’:
wrapper n v = return $ wrapper (n - 1) v
• Relevant bindings include
v :: a (bound at main.hs:7:11)
wrapper :: Int -> a -> b a (bound at main.hs:6:1)
Is it possible to create the function wrapper such as:
wrapper 4 'a' :: [Char]
[[[['a']]]]
Yes and no!
First of all, your type is inaccurate in the signature of the function. Taking your example of wrapper 4 'a', the return type of the function is m (m (m (m a))) (where m is []), not m a.
Secondly, we're not allowed infinite types in Haskell's type system, so we wouldn't be able to write down the correct type even if we wanted to!
That said, we can address both of these concerns with some new types that will do the type-level recursion for us. First, there's Fix:
newtype Fix f a = Fix { unFix :: f (Fix f a) }
Using this we can wrap infinitely:
wrap :: Monad m => Fix m a
wrap = Fix $ return $ wrap
As you can see, we don't need the base element (the a in your example) because we'll never hit the base of the recursion.
But that's not what you wanted either! The "infinite" here is actually something of a red herring: you want to be able to wrap something a finite number of times, using an argument to dictate the wrapping level.
You can do something like this with another wrapper:
data Wrap f a = Pure a | Wrap (f (Wrap f a))
wrapper :: Monad f => Int -> a -> Wrap f a
wrapper 0 x = Pure x
wrapper n x = Wrap $ pure $ wrapper (n-1) x
(This is in fact the free monad that we're using here)
What you're looking for exactly, though (i.e., no wrappers) can be done, however, it's quite involved, and probably not what you're looking for. I'll include it for completeness nonetheless.
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
import Data.Kind
import GHC.TypeLits
data N = Z | S N
type family Wrap (n :: N) (f :: Type -> Type) (a :: Type) :: Type where
Wrap Z f a = a
Wrap (S n) f a = Wrap n f (f a)
type family FromNat (n :: Nat) :: N where
FromNat 0 = Z
FromNat n = S (FromNat (n - 1))
data Ny (n :: N) where
Zy :: Ny Z
Sy :: Ny n -> Ny (S n)
class KnownN n where sing :: Ny n
instance KnownN Z where sing = Zy
instance KnownN n => KnownN (S n) where sing = Sy sing
wrap :: forall n f a. (KnownN (FromNat n), Monad f) => a -> Wrap (FromNat n) f a
wrap = go #(FromNat n) #f #a sing
where
go :: forall n f a. Monad f => Ny n -> a -> Wrap n f a
go Zy x = x
go (Sy n) x = go #_ #f n (return #f x)
main = print (wrap #4 'a' == [[[['a']]]])

Can I get KnownNat n to imply KnownNat (n * 3), etc?

I'm working with data types of this shape, using V from linear:
type Foo n = V (n * 3) Double -> Double
Having it fixed on n is pretty important, because I want to be able to ensure that I'm passing in the right number of elements at compile-time. This is a part of my program that already works well, independent of what I'm doing here.
For any KnownNat n, I can generate a Foo n satisfying the behavior that my program needs. For the purposes of this question it can be something silly like
mkFoo :: KnownNat (n * 3) => Foo n
mkFoo = sum
Or for a more meaningful example, it can generate a random V of the same length and use dot on the two. The KnownNat constraint here is redundant, but in reality, it's needed to do make a Foo. I make one Foo and use it for my entire program (or with multiple inputs), so this guarantees me that whenever I use it, I'm using on things with the same length, and on things that the structure of the Foo dictates.
And finally, I have a function that makes inputs for a Foo:
bar :: KnownNat (n * 3) => Proxy n -> [V (n * 3) Double]
bar is actually the reason why i'm using n * 3 as a type function, instead of just manually expanding it out. The reason is that bar might do its job by using three vectors of length n and appending them all together as a vector of length n * 3. Also, n is a much more meaningful parameter to the function, semantically, than n * 3. This also lets me disallow improper values like n's that aren't multiples of 3, etc.
Now, before, everything worked fine as long as I defined a type synonym at the beginning:
type N = 5
And I can just then pass in Proxy :: Proxy N to bar, and use mkFoo :: Foo N. And everything worked fine.
-- works fine
doStuff :: [Double]
doStuff = let inps = bar (Proxy :: Proxy N)
in map (mkFoo :: Foo N) inps
But now I want to be able to adjust N during runtime by loading information from a file, or from command line arguments.
I tried doing it by calling reflectNat:
doStuff :: Integer -> Double
doStuff n = reflectNat 5 $ \pn#(Proxy :: Proxy n) ->
let inps = bar (Proxy :: Proxy n)
in map (mkFoo :: Foo n) inps
But...bar and mkFoo require KnownNat (n * 3), but reflectNat just gives me KnownNat n.
Is there any way I can generalize the proof that reflectNat gives me to satisfy foo ?
So, three months later, I have been going back and forth on good ways to accomplish this, but I finally settled on an actual very succinct trick that doesn't require any throwaway newtypes; it involves using a Dict from the constraints library; you could easily write a:
natDict :: KnownNat n => Proxy n -> Dict (KnownNat n)
natDict _ = Dict
triple :: KnownNat n => Proxy n -> Dict (KnownNat (n * 3))
triple p = reifyNat (natVal p * 3) $
\p3 -> unsafeCoerce (natDict p3)
And once you get Dict (KnownNat (n * 3), you can pattern match on it to get the (n * 3) instance in scope:
case triple (Proxy :: Proxy n) of
Dict -> -- KnownNat (n * 3) is in scope
You can actually set these up as generic, too:
addNats :: (KnownNat n, KnownNat m) => Proxy n -> Proxy m -> Dict (KnownNat (n * m))
addNats px py = reifyNat (natVal px + natVal py) $
\pz -> unsafeCoerce (natDict pz)
Or, you can make them operators and you can use them to "combine" Dicts:
infixl 6 %+
infixl 7 %*
(%+) :: Dict (KnownNat n) -> Dict (KnownNat m) -> Dict (KnownNat (n + m))
(%*) :: Dict (KnownNat n) -> Dict (KnownNat m) -> Dict (KnownNat (n * m))
And you can do things like:
case d1 %* d2 %+ d3 of
Dict -> -- in here, KnownNat (n1 * n2 + n3) is in scope
I've wrapped this up in a nice library, typelits-witnesses that I've been using. Thank you all for your help!
I post another answer as it is more direct, editing the previous won't make sense.
In fact using the trick (popularised if not invented by Edward Kmett), from reflections reifyNat:
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
import GHC.TypeLits
import Data.Proxy
import Unsafe.Coerce
newtype MagicNat3 r = MagicNat3 (forall (n :: Nat). KnownNat (n * 3) => Proxy n -> r)
trickValue :: Integer -> Integer
trickValue = (*3)
-- No type-level garantee that the function will be called with (n * 3)
-- you have to believe us
trick :: forall a n. KnownNat n => Proxy n -> (forall m. KnownNat (m * 3) => Proxy m -> a) -> a
trick p f = unsafeCoerce (MagicNat3 f :: MagicNat3 a) (trickValue (natVal p)) Proxy
test :: forall m. KnownNat (m * 3) => Proxy m -> Integer
test _ = natVal (Proxy :: Proxy (m * 3))
So when you run it:
λ *Main > :t trick (Proxy :: Proxy 4) test :: Integer
trick (Proxy :: Proxy 4) test :: Integer :: Integer
λ *Main > trick (Proxy :: Proxy 4) test :: Integer
12
The trick is based on the fact that in GHC the one member class dictionaries (like KnownNat) are represented by the member itself. In KnownNat situation it turns out to be Integer. So we just unsafeCoerce it there. Universal quantification makes it sound from the outside.
Your question isn't very descriptive, so I'll try my best to feel blanks:
Let's assume that Blah n is Proxy n.
I also assume that reflectNat is a way to call universally quantified (over typelevel Nat) function, using term-level natural number.
I don't know better way than writing your own reflectNat providing that
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
import GHC.TypeLits
import Data.Proxy
data Vec a (n :: Nat) where
Nil :: Vec a 0
Cons :: a -> Vec a n -> Vec a (1 + n)
vecToList :: Vec a n -> [a]
vecToList Nil = []
vecToList (Cons h t) = h : vecToList t
repl :: forall n a. KnownNat n => Proxy n -> a -> Vec a n
repl p x = undefined -- this is a bit tricky with Nat from GHC.TypeLits, but possible
foo :: forall (n :: Nat). KnownNat (1 + n) => Proxy n -> Vec Bool (1 + n)
foo _ = repl (Proxy :: Proxy (1 + n)) True
-- Here we have to write our own version of 'reflectNat' providing right 'KnownNat' instances
-- so we can call `foo`
reflectNat :: Integer -> (forall n. KnownNat (1 + n) => Proxy (n :: Nat) -> a) -> a
reflectNat = undefined
test :: [Bool]
test = reflectNat 5 $ \p -> vecToList (foo p)
Alternatively, using singletons you can use SomeSing. Then types will be different
reflectNat :: Integer -> (forall (n :: Nat). SomeSing (n :: Nat) -> a) -> a
I.e. instead of magic dict KnownNat you have concrete singleton value. Thus in foo you'd need to construct SomeSing (1 + n) explicitly, given SomeSing n -- which is quite simple.
In run-time both KnownNat dictionary and SomeSing value will be passed around carring the number value, and explicit is IMHO better in this situation.p)

Behavior of type level naturals in GHC 7.8

If you want vectors indexed by their length you can do something like this:
{-# LANGUAGE
DataKinds, GADTs, TypeOperators, TypeFamilies, StandaloneDeriving
#-}
data N = P N | Z
type family Add (n :: N) (m :: N) :: N
type instance Add Z a = a
type instance Add (P a) b = P (Add a b)
infixr 5 :>
data Vect n a where
V0 :: Vect Z a
(:>) :: a -> Vect n a -> Vect (P n) a
deriving instance Show a => Show (Vect n a)
concatV :: Vect n a -> Vect m a -> Vect (Add n m) a
concatV V0 y = y
concatV (x :> xs) y = x :> concatV xs y
In ghc 7.8 I was hoping this would become obsolete with the new type literals, but the direct conversion is invalid:
{-# LANGUAGE
DataKinds, GADTs, TypeOperators, TypeFamilies, StandaloneDeriving
#-}
import GHC.TypeLits
infixr 5 :>
data Vect (n :: Nat) a where
V0 :: Vect 0 a
(:>) :: a -> Vect n a -> Vect (n+1) a
deriving instance Show a => Show (Vect n a)
concatV :: Vect n a -> Vect m a -> Vect (n + m) a
concatV V0 y = y
concatV (x :> xs) y = x :> concatV xs y
Unfortunatley this gives an error: NB:+' is a type function, and may not be injective `. I understand why this happens, but since the type literals are compiler magic anyways, I don't know why the compiler could not magic this away either.
I tried changing Vect : (:>) :: a -> Vect (n-1) a -> Vect n a. This way there is an explicit formula for the inner vector, but this gives the error:
Couldn't match type `(n + m) - 1' with `(n - 1) + m'
Expected type: Vect ((n + m) - 1) a
Actual type: Vect ((n - 1) + m) a
So now it requires a proof of basic arithmetic. I haven't been able to make either version work. Is there a way to write a proof of (n + m) - o == (n - o) + m for the compiler, or somehow make the first version work?
Type-level naturals still don't really do computation yet. GHC 7.10 is slated to have an SMT solver integrated to finally handle everything you think it should be able to.
As a theoretically unsound but working answer to your actual question - unsafeCoerce exists for the case when you know two expressions have the same type, but the compiler doesn't.
The GHC 7.8 solver still won't solve for a lot of arithmetic relations with type naturals. Though in this case it's perfectly safe to use unsafeCoerce to force GHC to recognize the intended type.
{-# LANGUAGE
DataKinds, GADTs, TypeOperators, TypeFamilies, StandaloneDeriving
#-}
import GHC.TypeLits
import Unsafe.Coerce
infixr 5 :>
data Vect (n :: Nat) a where
V0 :: Vect 0 a
(:>) :: a -> Vect n a -> Vect (n+1) a
deriving instance Show a => Show (Vect n a)
concatV :: Vect n a -> Vect m a -> Vect (n + m) a
concatV V0 y = unsafeCoerce y
concatV (x :> xs) y = unsafeCoerce $ x :> concatV xs y

Type-level nats with literals and an injective successor? (N-ary compose)

I'm generalizing this n-ary complement to an n-ary compose, but I'm having trouble making the interface nice. Namely, I can't figure out how to use numeric literals at the type level while still being able to pattern match on successors.
Rolling my own nats
Using roll-my-own nats, I can make n-ary compose work, but I can only pass n as an iterated successor, not as a literal:
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module RollMyOwnNats where
import Data.List (genericIndex)
-- import Data.Proxy
data Proxy (n::Nat) = Proxy
----------------------------------------------------------------
-- Stuff that works.
data Nat = Z | S Nat
class Compose (n::Nat) b b' t t' where
compose :: Proxy n -> (b -> b') -> t -> t'
instance Compose Z b b' b b' where
compose _ f x = f x
instance Compose n b b' t t' => Compose (S n) b b' (a -> t) (a -> t') where
compose _ g f x = compose (Proxy::Proxy n) g (f x)
-- Complement a binary relation.
compBinRel :: (a -> a -> Bool) -> (a -> a -> Bool)
compBinRel = compose (Proxy::Proxy (S (S Z))) not
----------------------------------------------------------------
-- Stuff that does not work.
instance Num Nat where
fromInteger n = iterate S Z `genericIndex` n
-- I now have 'Nat' literals:
myTwo :: Nat
myTwo = 2
-- But GHC thinks my type-level nat literal is a 'GHC.TypeLits.Nat',
-- even when I say otherwise:
compBinRel' :: (a -> a -> Bool) -> (a -> a -> Bool)
compBinRel' = compose (Proxy::Proxy (2::Nat)) not
{-
Kind mis-match
An enclosing kind signature specified kind `Nat',
but `2' has kind `GHC.TypeLits.Nat'
In an expression type signature: Proxy (2 :: Nat)
In the first argument of `compose', namely
`(Proxy :: Proxy (2 :: Nat))'
In the expression: compose (Proxy :: Proxy (2 :: Nat)) not
-}
Using GHC.TypeLits.Nat
Using GHC.TypeLits.Nat, I get type-level nat literals, but there is no successor constructor that I can find, and using the type function (1 +) doesn't work, because GHC (7.6.3) can't reason about injectivity of type functions:
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module UseGHCTypeLitsNats where
import GHC.TypeLits
-- import Data.Proxy
data Proxy (t::Nat) = Proxy
----------------------------------------------------------------
-- Stuff that works.
class Compose (n::Nat) b b' t t' where
compose :: Proxy n -> (b -> b') -> t -> t'
instance Compose 0 b b' b b' where
compose _ f x = f x
instance (Compose n b b' t t' , sn ~ (1 + n)) => Compose sn b b' (a -> t) (a -> t') where
compose _ g f x = compose (Proxy::Proxy n) g (f x)
----------------------------------------------------------------
-- Stuff that does not work.
-- Complement a binary relation.
compBinRel , compBinRel' :: (a -> a -> Bool) -> (a -> a -> Bool)
compBinRel = compose (Proxy::Proxy 2) not
{-
Couldn't match type `1 + (1 + n)' with `2'
The type variable `n' is ambiguous
Possible fix: add a type signature that fixes these type variable(s)
In the expression: compose (Proxy :: Proxy 2) not
In an equation for `compBinRel':
compBinRel = compose (Proxy :: Proxy 2) not
-}
{-
No instance for (Compose n Bool Bool Bool Bool)
arising from a use of `compose'
The type variable `n' is ambiguous
Possible fix: add a type signature that fixes these type variable(s)
Note: there is a potential instance available:
instance Compose 0 b b' b b'
-}
compBinRel' = compose (Proxy::Proxy (1+(1+0))) not
{-
Couldn't match type `1 + (1 + 0)' with `1 + (1 + n)'
NB: `+' is a type function, and may not be injective
The type variable `n' is ambiguous
Possible fix: add a type signature that fixes these type variable(s)
Expected type: Proxy (1 + (1 + 0))
Actual type: Proxy (1 + (1 + n))
In the first argument of `compose', namely
`(Proxy :: Proxy (1 + (1 + 0)))'
-}
I agree that semantic editor combinators are more elegant and more general here -- and concretely, it will always be easy enough to write (.) . (.) . ... (n times) instead of compose (Proxy::Proxy n) -- but I'm frustrated that I can't make the n-ary composition work as well as I expected. Also, it seems I would run into similar problems for other uses of GHC.TypeLits.Nat, e.g. when trying to define a type function:
type family T (n::Nat) :: *
type instance T 0 = ...
type instance T (S n) = ...
UPDATE: Summary and adaptation of the accepted answer
There's a lot of interesting stuff going on in the accepted answer,
but the key for me is the Template Haskell trick in the GHC 7.6
solution: that effectively lets me add type-level literals to my GHC
7.6.3 version, which already had injective successors.
Using my types above, I define literals via TH:
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
module RollMyOwnLiterals where
import Language.Haskell.TH
data Nat = Z | S Nat
nat :: Integer -> Q Type
nat 0 = [t| Z |]
nat n = [t| S $(nat (n-1)) |]
where I've moved my Nat declaration into the new module to avoid an
import loop. I then modify my RollMyOwnNats module:
+import RollMyOwnLiterals
...
-data Nat = Z | S Nat
...
+compBinRel'' :: (a -> a -> Bool) -> (a -> a -> Bool)
+compBinRel'' = compose (Proxy::Proxy $(nat 2)) not
Unfortunately your question cannot be answered in principle in the currently released version of GHC (GHC 7.6.3) because of a consistency problem pointed out in the recent message
http://www.haskell.org/pipermail/haskell-cafe/2013-December/111942.html
Although type-level numerals look like numbers they are not guaranteed to behave like numbers at all (and they don't). I have seen Iavor Diatchki and colleagues have implemented proper type level arithmetic in GHC (which as as sound as the SMT solver used as a back end -- that is, we can trust it). Until that version is released, it is best to avoid type level numeric literals, however cute they may seem.
EDIT: Rewrote answer. It was getting a little bulky (and a little buggy).
GHC 7.6
Since type level Nats are somewhat... incomplete (?) in GHC 7.6, the least verbose way of achieving what you want is a combination of GADTs and type families.
{-# LANGUAGE GADTs, TypeFamilies #-}
module Nats where
-- Type level nats
data Zero
data Succ n
-- Value level nats
data N n f g where
Z :: N Zero (a -> b) a
S :: N n f g -> N (Succ n) f (a -> g)
type family Compose n f g
type instance Compose Zero (a -> b) a = b
type instance Compose (Succ n) f (a -> g) = a -> Compose n f g
compose :: N n f g -> f -> g -> Compose n f g
compose Z f x = f x
compose (S n) f g = compose n f . g
The advantage of this particular implementation is that it doesn't use type classes, so applications of compose aren't subject to the monomorphism restriction. For example, compBinRel = compose (S (S Z)) not will type check without type annotations.
We can make this nicer with a little Template Haskell:
{-# LANGUAGE TemplateHaskell #-}
module Nats.TH where
import Language.Haskell.TH
nat :: Integer -> Q Exp
nat 0 = conE 'Z
nat n = appE (conE 'S) (nat (n - 1))
Now we can write compBinRel = compose $(nat 2) not, which is much more pleasant for larger numbers. Some may consider this "cheating", but seeing as we're just implementing a little syntactic sugar, I think it's alright :)
GHC 7.8
The following works on GHC 7.8:
-- A lot more extensions.
{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, PolyKinds, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Nats where
import GHC.TypeLits
data N = Z | S N
data P n = P
type family Index n where
Index 0 = Z
Index n = S (Index (n - 1))
-- Compose is defined using Z/S instead of 0, 1, ... in order to avoid overlapping.
class Compose n f r where
type Return n f r
type Replace n f r
compose' :: P n -> (Return n f r -> r) -> f -> Replace n f r
instance Compose Z a b where
type Return Z a b = a
type Replace Z a b = b
compose' _ f x = f x
instance Compose n f r => Compose (S n) (a -> f) r where
type Return (S n) (a -> f) r = Return n f r
type Replace (S n) (a -> f) r = a -> Replace n f r
compose' x f g = compose' (prev x) f . g
where
prev :: P (S n) -> P n
prev P = P
compose :: Compose (Index n) f r => P n -> (Return (Index n) f r -> r) -> f -> Replace (Index n) f r
compose x = compose' (convert x)
where
convert :: P n -> P (Index n)
convert P = P
-- This does not type check without a signature due to the monomorphism restriction.
compBinRel :: (a -> a -> Bool) -> (a -> a -> Bool)
compBinRel = compose (P::P 2) not
-- This is an example where we compose over higher order functions.
-- Think of it as composing (a -> (b -> c)) and ((b -> c) -> c).
-- This will not typecheck without signatures, despite the fact that it has arguments.
-- However, it will if we use the first solution.
appSnd :: b -> (a -> b -> c) -> a -> c
appSnd x f = compose (P::P 1) ($ x) f
However, this implementation has a few downsides, as annotated in the source.
I attempted (and failed) to use closed type families to infer the composition index automatically. It might have been possible to infer higher order functions like this:
-- Given r and f, where f = x1 -> x2 -> ... -> xN -> r, Infer r f returns N.
type family Infer r f where
Infer r r = Zero
Infer r (a -> f) = Succ (Infer r f)
However, Infer won't work for higher order functions with polymorphic arguments. For example:
ghci> :kind! forall a b. Infer a (b -> a)
forall a b. Infer a (b -> a) :: *
= forall a b. Infer a (b -> a)
GHC can't expand Infer a (b -> a) because it doesn't perform an occurs check when matching closed family instances. GHC won't match the second case of Infer on the off chance that a and b are instantiated such that a unifies with b -> a.

Resources