Consider the following code:
type CFunctor f = forall x y. (x -> y -> Constraint) -> f x -> f y -> Constraint
type MapList :: CFunctor []
class MapList c xs ys
instance MapList c '[] '[]
instance (c x y, MapList c xs ys) => MapList c (x ': xs) (y ': ys)
This works fine, but it's desirable in some situations to "make things compute" by introducing a functional dependency of the form:
class MapList c xs ys | c xs -> ys
With the functional dependency we have the following code:
type CFunctor f = forall x y. (x -> y -> Constraint) -> f x -> f y -> Constraint
type MapList :: CFunctor []
class MapList c xs ys | c xs -> ys
instance MapList c '[] '[]
instance (c x y, MapList c xs ys) => MapList c (x ': xs) (y ': ys)
This does not compile however, and produces the following error on the last instance:
[typecheck] [E] • Illegal instance declaration for ‘MapList c (x : xs) (y : ys)’
The liberal coverage condition fails in class ‘MapList’
for functional dependency: ‘c xs -> ys’
Reason: lhs types ‘c’, ‘x : xs’
do not jointly determine rhs type ‘y : ys’
Un-determined variable: y
• In the instance declaration for ‘MapList c (x : xs) (y : ys)’
This makes sense: c + xs determines ys due to the recursive use of MapList c xs ys (which has a functional dependency). But c + x ': xs determines c + y ': ys only if x determines y, which is a property we must require of the class being passed in for c.
But how can we adjust the CFunctor kind to demand this? As far as I'm aware there is no vocabulary in kind signatures to discuss functional dependencies. Is there still a way I can make this work?
One workaround is to create a wrapper class that simply demands whatever your original constraint was, plus a functional dependency. The only way to satisfy the functional dependency in the wrapper is to have a functional dependency in the original class.
To wit:
type FDep :: (a -> b -> Constraint) -> a -> b -> Constraint
class c x y => FDep c x y | c x -> y
Now we can write:
type MapList :: CFunctor []
class MapList c xs ys | c xs -> ys
instance MapList (FDep c) '[] '[]
instance (FDep c x y, MapList (FDep c) xs ys) => MapList (FDep c) (x ': xs) (y ': ys)
And have it type check.
When passing in some arrow, e.g.:
class Fst ab a | ab -> a
instance Fst '(a, b) a
We simply instantiate FDep for it as well, to witness the fact that it has the relevant functional dependency:
instance Fst ab a => FDep Fst ab a
Somewhat curiously, our functor mappings are closed with respect to FDep-ness, as illustrated below:
type MapList :: CFunctor []
class MapList c xs ys | c xs -> ys
instance MapList c xs ys => FDep (MapList c) xs ys
instance MapList (FDep c) '[] '[]
instance (FDep c x y, MapList (FDep c) xs ys) => MapList (FDep c) (x ': xs) (y ': ys)
This is nice, because it allows functors to compose arbitrarily. It suggests we are doing some kind of weird Constraint enriched category theory whose objects are kinds, and whose morphisms are functionally dependent classes.
Here is a worked example of using our type level computer:
(^$) :: FDep c x y => Proxy c -> Proxy x -> Proxy y
(^$) _ _ = Proxy
class Fst ab a | ab -> a
instance Fst ab a => FDep Fst ab a
instance Fst '(a, b) a
test :: _
test = Proxy #(MapList (FDep Fst)) ^$ Proxy #'[ '(0, 1)]
The type hole error that results is:
[typecheck] [E] • Found type wildcard ‘_’ standing for ‘Proxy '[0]’
To use the inferred type, enable PartialTypeSignatures
• In the type signature: test :: _
Of course, producing a Cartesian product of heterogeneous lists can be done in a number of way in Haskell, such as:
[(x,y) | x <- [1,2,3], y <- [4,5,6]]
or
(,) <$> [1,2,3] <*> [4,5,6]
But what I want is a function like this:
heteroCartesian ::
(a1, a2, ... , an) ->
(b1, b2, ... , bn) ->
((a1,b1), (a1,b2), ... , (a1,bn), (a2,b1), (a2,b2), ... , (a2,bn), (an,b1), ... ,(an,b2), ... , (an,bn))
So I can do something like this:
f (1,'a',True) (2,'b') ==
((1,2),(1,'b'),('a',2),('a','b'),(True,2),(True,'b'))
I don't mind whether I'm using tuples or something else, but I need to retain the type information like I have above.
The reason why I want this is to create test cases. I've got a bunch of say n functions and m values. Eventually I will map a function over these which reduces them all to the same type (a Test) but up to that point there's a bunch of different types for the n*m testcases I want to perform (it's actually not that simple as some functions can only take restricted subsets of the values).
So naturally it would good to have other functions these heterogeneous lists, like some sort of map for example.
I've had a look at HList, but it hasn't been updated in the last year and a bit, and I wasn't sure if it was the most appropriate tool anyway.
It appears HList has indeed bit rotted a bit. Nonetheless, nothing stops us from rolling our own HList! In fact, we can also heavily rely on singletons for our type level list operations. First, some imports:
{-# LANGUAGE DataKinds, TypeOperators, GADTs,TypeFamilies, UndecidableInstances, PolyKinds, FlexibleInstances #-}
import Data.Singletons
import Data.Promotion.Prelude.List
Then the actual definition of an HList (simpler than the one the package of that name uses, for reasons described here and here).
data HList (l :: [*]) where
HNil :: HList '[]
HCons :: x -> HList xs -> HList (x ': xs)
-- Notice we are using `:++` from singletons
append :: HList xs -> HList ys -> HList (xs :++ ys)
append HNil xs = xs
append (x `HCons` xs) ys = x `HCons` (xs `append` ys)
-- Notice we are using `Map` and `TyCon1` from singletons. Bow before the magic
-- of type level HOFs. ;)
addTuple :: z -> HList xs -> HList (Map (TyCon1 ((,) z)) xs)
addTuple _ HNil = HNil
addTuple x (y `HCons` ys) = (x,y) `HCons` addTuple x ys
-- These instances aren't needed, but they let us check the output of our code
instance (Show x, Show (HList xs)) => Show (HList (x ': xs)) where
show (x `HCons` xs) = show x ++ " " ++ show xs
instance Show (HList '[]) where
show HNil = ""
Finally, we get to the cartesian product itself:
type family Cartesian (ys :: [*]) (xs :: [*]) :: [*] where
Cartesian '[] xs = '[]
Cartesian (y ': ys) xs = Map (TyCon1 ((,) y)) xs :++ Cartesian ys xs
cartesian :: HList xs -> HList ys -> HList (xs `Cartesian` ys)
cartesian HNil _ = HNil
cartesian (y `HCons` ys) xs = addTuple y xs `append` cartesian ys xs
Which we can test works:
ghci> h1 = HCons True $ HCons LT $ HCons () $ HCons (1 :: Int) HNil
ghci> h2 = HCons () $ HCons "hello" $ HCons 'a' HNil
ghci> h1 `cartesian` h2
(True,()) (True,"hello") (True,'a') (LT,()) (LT,"hello") (LT,'a') ((),()) ((),"hello") ((),'a') (1,()) (1,"hello") (1,'a')
With all that said, I'm not sure this is really worth it for tests. Fundamentally, I expect tests to be simpler and more readable than the code I am testing. And HList is not my idea of a simple test. But, to each his own. :)
A way to solve this, is by using template Haskell for that:
import Control.Monad(replicateM)
import Language.Haskell.TH.Syntax(newName,Pat(TupP,VarP),Exp(LamE,TupE,VarE))
heteroCartesian m n = do
as <- replicateM m $ newName "a"
bs <- replicateM n $ newName "b"
return $ LamE [TupP (map VarP as),TupP (map VarP bs)] $ TupE $ [TupE [VarE ai,VarE bi] | ai <- as, bi <- bs]
Now in another file, you can use the function:
{-# LANGUAGE TemplateHaskell #-}
heteroCartesian23 = $(heteroCartesian 2 3)
In that case heteroCartesian23 will have type heteroCartesian23 :: (a1,a2) -> (b1,b2,b3) -> ((a1,b1),(a1,b2),(a1,b3),(a2,b1),(a2,b2),(a2,b3)).
Or you can use it in ghci:
$ ghci -XTemplateHaskell library.hs
GHCi, version 7.10.3: http://www.haskell.org/ghc/ :? for help
[1 of 1] Compiling Main ( ha.hs, interpreted )
Ok, modules loaded: Main.
*Main> :t $(heteroCartesian 3 4)
$(heteroCartesian 3 4)
:: (t, t1, t5)
-> (t2, t3, t4, t6)
-> ((t, t2),
(t, t3),
(t, t4),
(t, t6),
(t1, t2),
(t1, t3),
(t1, t4),
(t1, t6),
(t5, t2),
(t5, t3),
(t5, t4),
(t5, t6))
I am having a difficult time convincing GHC that certain properties
of list manipulation are true. Before I provide the code that I'm
working on, I'll give a brief example of the property I'm interested in.
Suppose we have some type-level list xs:
xs ~ '[ 'A, 'B, 'C, 'D, 'E, 'F ]
And we drop some of the elements and also take the same number of
elements:
Drop 2 xs ~ '[ 'C, 'D, 'E, 'F ]
TakeReverse 2 xs ~ '[ 'B, 'A ]
It should be obvious that if I apply Drop and TakeReverse
using the successor of 2, then I can just pop the 'C off of
Drop 2 xs and put it on top of TakeReverse 2 xs:
Drop 3 xs ~ '[ 'D, 'E, 'F ]
TakeReverse 3 xs ~ '[ 'C, 'B, 'A ]
The following code has a function named moveRight that attempts to
use this property. I have cut my actual code down to a somewhat small example that
illustrates the issue and has no dependencies.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
module Minimal where
import Data.Type.Equality
data Nat = Z | S Nat
data Natty (n :: Nat) where
Zy :: Natty 'Z
Sy :: Natty n -> Natty ('S n)
data HRec (vs :: [*]) where
HRecNil :: HRec '[]
HRecCons :: x -> HRec xs -> HRec (x ': xs)
data HProxy (vs :: [k]) where
HProxyNil :: HProxy '[]
HProxyCons :: HProxy xs -> HProxy (x ': xs)
data Parts n rs = Parts
{ partLeft :: HRec (Drop n rs)
, partRight :: HRec (TakeReverse n rs)
, partNatty :: Natty n
, partProxy :: HProxy rs
}
-- The type families Drop, Take, and TakeReverse
-- are all partial.
type family Drop (n :: Nat) (xs :: [k]) :: [k] where
Drop 'Z xs = xs
Drop ('S n) (x ': xs) = Drop n xs
type family Take (n :: Nat) (xs :: [k]) :: [k] where
Take 'Z xs = '[]
Take ('S n) (x ': xs) = x ': Take n xs
type family TakeReverse (n :: Nat) (xs :: [k]) :: [k] where
TakeReverse n xs = TakeReverseHelper '[] n xs
type family TakeReverseHelper (ys :: [k]) (n :: Nat) (xs :: [k]) :: [k] where
TakeReverseHelper res 'Z xs = res
TakeReverseHelper res ('S n) (x ': xs) = TakeReverseHelper (x ': res) n xs
moveRight :: Parts n rs -> Parts (S n) rs
moveRight (Parts pleft#(HRecCons pleftHead _) pright natty proxy) =
case dropOneProof natty proxy of
Refl -> Parts (dropOne pleft) (HRecCons pleftHead pright) (Sy natty) proxy
dropOneProof :: Natty n -> HProxy rs -> (Drop ('S n) rs :~: Drop ('S 'Z) (Drop n rs))
dropOneProof Zy _ = Refl
dropOneProof (Sy n) (HProxyCons rs) = case dropOneProof n rs of
Refl -> Refl
dropOne :: HRec rs -> HRec (Drop ('S 'Z) rs)
dropOne (HRecCons _ rs) = rs
This code does not compile because of moveRight. Basically, I'm able to
prove that dropping an additional element from the left side gives it
the right type, but I can't show that adding this element to the right
side makes it have the right type.
I'm really open to any changes. I'm fine with changing the type families,
introducing extra witnesses, etc., as long as moveRight becomes
possible to write.
If I need to further clarify what I am trying to do, please let me know. Thanks.
The problem with your representation is that you try to make the position of the split explicit, but don't enforce the validity of the position index.
As it is currently moveRight :: Parts n rs -> Parts (S n) rs can't be implemented, because if n is out of bounds, Take and the other type family applications cannot reduce and therefore no value can be given in the result.
There are many ways to solve this issue. The simplest is to make the types in the left and right parts of the context explicit:
type HZipper xs ys = (HRec xs, HRec ys)
moveRight :: HZipper xs (y ': ys) -> HZipper (y ': xs) ys
moveRight'(xs, HCons y ys) = (HCons y xs, ys)
This is actually just as strong representatation as your original Parts. provided that we enforce the bounds on the n index there. That's because both types indicate the whole list and the exact position of the split. From HZipper xs ys, the original type list can be computed as Reverse xs ++ ys with the appropriate ++ and Reverse type families. This is sometimes less convenient, but on the up side HZipper has much simpler internals.
Alternatively, you can hide the position of split existentially. In any case, this requires proof writing for moveRight:
import Data.Type.Equality
import Data.Proxy
data HRec vs where
HNil :: HRec '[]
HCons :: x -> HRec xs -> HRec (x ': xs)
type family (++) xs ys where
'[] ++ ys = ys
(x ': xs) ++ ys = x ': (xs ++ ys)
type family Reverse xs where
Reverse '[] = '[]
Reverse (x ': xs) = Reverse xs ++ '[x]
data HZipper xs where
HZipper :: HRec ys -> HRec zs -> HZipper (Reverse ys ++ zs)
hcat :: HRec xs -> HRec ys -> HRec (xs ++ ys)
hcat HNil ys = ys
hcat (HCons x xs) ys = HCons x (hcat xs ys)
hreverse :: HRec xs -> HRec (Reverse xs)
hreverse HNil = HNil
hreverse (HCons x xs) = hreverse xs `hcat` (HCons x HNil)
catAssoc :: HRec xs -> Proxy ys -> Proxy zs -> (xs ++ (ys ++ zs)) :~: ((xs ++ ys) ++ zs)
catAssoc HNil xs ys = Refl
catAssoc (HCons x xs) ys zs = case catAssoc xs ys zs of
Refl -> Refl
moveRight :: HZipper xs -> HZipper xs
moveRight (HZipper ls HNil) = HZipper ls HNil
moveRight (HZipper ls (HCons (x :: x) (xs :: HRec xs))) =
case catAssoc (hreverse ls) (Proxy :: Proxy '[x]) (Proxy :: Proxy xs) of
Refl -> HZipper (HCons x ls) xs
There's a third possibility, namely adding an existential bounds check inside the original Parts, or having moveRight :: InBounds (S n) rs -> Parts n rs -> Parts (S n) rs, where InBounds is a proof of inbounds-ness. Or we could have InBounds (S n) rs => ... with InBounds a type family returning a class constraint. This approach would also require quite a bit of proof-writing though.
Defined:
type family (xs :: [*]) ++ (ys :: [*]) where
'[] ++ ys = ys
(x ': xs) ++ ys = x ': (xs ++ ys)
I have a GADT that's kinda like
data Foo :: [*] -> * -> * where
Foo0 :: a -> Foo '[] a
Foo1 :: Foo '[a] a
Foo2 :: Foo vs a -> Foo us a -> Foo (vs ++ us) a
And I want to do something like
test :: Foo '[] Int -> Int
test (Foo0 x) = x
test (Foo2 x y) = test x + test y
But I can't use test on x or y because x ~ Foo '[] Int and y ~ Foo '[] Int have to be proven. But I want to say that this is proven from the fact that vs ++ us ~ '[] means that the individual vs and us of x and y are necessarily '[].
Is there any way to do this with type families, or maybe switching over to a multi param typeclass approach with fundeps?
Thanks!
Don't touch the green smile!
The presence of ‘green slime’ — defined functions in the return types
of constructors — is a danger sign.
The simplest workaround is to generalize test and then instantiate:
gtest :: Foo xs Int -> Int
gtest (Foo0 x) = x
gtest (Foo2 x y) = gtest x + gtest y
test :: Foo '[] Int -> Int
test = gtest
You could add two type families that would serve as inverses of ++, and without loss of generality add them as constraints to the Foo2 constructor. Through those inverse type families GHC would be able to infer exactly what you're asking from it.
Here's an example implementation of CutX and CutY such that r ~ a ++ b <=> a ~ CutY r b <=> b ~ CutX r a.
type family (xs :: [*]) ++ (ys :: [*]) where
'[] ++ ys = ys
(x ': xs) ++ ys = x ': (xs ++ ys)
type family CutX (rs :: [*]) (xs :: [*]) where
CutX '[] xs = '[]
CutX rs '[] = rs
CutX (r ': rs) (x ': xs) = CutX rs xs
type family ZipWithConst (xs :: [*]) (ys :: [*]) where
ZipWithConst '[] ys = '[]
ZipWithConst xs '[] = '[]
ZipWithConst (x ': xs) (y ': ys) = y ': ZipWithConst xs ys
type CutY rs ys = ZipWithConst rs (CutX rs ys)
data Foo :: [*] -> * -> * where
Foo0 :: a -> Foo '[] a
Foo1 :: Foo '[a] a
Foo2 :: (rs ~ (vs ++ us), us ~ CutX rs vs, vs ~ CutY rs us) => Foo vs a -> Foo us a -> Foo rs a
I have a witness type for type-level lists,
data List xs where
Nil :: List '[]
Cons :: proxy x -> List xs -> List (x ': xs)
as well as the following utilities.
-- Type level append
type family xs ++ ys where
'[] ++ ys = ys
(x ': xs) ++ ys = x ': (xs ++ ys)
-- Value level append
append :: List xs -> List ys -> List (xs ++ ys)
append Nil ys = ys
append (Cons x xs) ys = Cons x (append xs ys)
-- Proof of associativity of (++)
assoc :: List xs -> proxy ys -> proxy' zs -> ((xs ++ ys) ++ zs) :~: (xs ++ (ys ++ zs))
assoc Nil _ _ = Refl
assoc (Cons _ xs) ys zs = case assoc xs ys zs of Refl -> Refl
Now, I have two different but equivalent definitions of a type-level reverse function,
-- The first version, O(n)
type Reverse xs = Rev '[] xs
type family Rev acc xs where
Rev acc '[] = acc
Rev acc (x ': xs) = Rev (x ': acc) xs
-- The second version, O(n²)
type family Reverse' xs where
Reverse' '[] = '[]
Reverse' (x ': xs) = Reverse' xs ++ '[x]
The first is more efficient, but the second is easier to use when proving things to the compiler, so it would be nice to have a proof of equivalence. In order to do this, I need a proof of Rev acc xs :~: Reverse' xs ++ acc. This is what I came up with:
revAppend :: List acc -> List xs -> Rev acc xs :~: Reverse' xs ++ acc
revAppend _ Nil = Refl
revAppend acc (Cons x xs) =
case (revAppend (Cons x acc) xs, assoc (reverse' xs) (Cons x Nil) acc) of
(Refl, Refl) -> Refl
reverse' :: List xs -> List (Reverse' xs)
reverse' Nil = Nil
reverse' (Cons x xs) = append (reverse' xs) (Cons x Nil)
Unfortunately, revAppend is O(n³), which completely defeats the purpose of this exercise. However, we can bypass all this and get O(1) by using unsafeCoerce:
revAppend :: Rev acc xs :~: Reverse' xs ++ acc
revAppend = unsafeCoerce Refl
Is this safe? What about the general case? For example, if I have two type families F :: k -> * and G :: k -> *, and I know that they are equivalent, is it safe to define the following?
equal :: F a :~: G a
equal = unsafeCoerce Refl
It would be very nice if GHC used a termination checker on expressions e::T where T has only one constructor with no arguments K (e.g. :~:, ()). When the check succeeds, GHC could rewrite e as K skipping the computation completely. You would have to rule out FFI, unsafePerformIO, trace, ... but it seems feasible. If this were implemented, it would solve the posted question very nicely, allowing one to actually write proofs having zero runtime cost.
Failing this, you can use unsafeCoerce in the meanwhile, as you propose. If you are really, really sure that two type are the same you can use it safely. The typical example is implementing Data.Typeable. Of course, a misuse of unsafeCoerce on different types would lead to unpredictable effects, hopefully a crash.
You could even write your own "safer" variant of unsafeCoerce:
unsafeButNotSoMuchCoerce :: (a :~: b) -> a -> b
#ifdef CHECK_TYPEEQ
unsafeButNotSoMuchCoerce Refl = id
#else
unsafeButNotSoMuchCoerce _ = unsafeCoerce
#endif
If CHECK_TYPEEQ is defined it leads to slower code. If undefined, it skips it and coerces at zero cost. In the latter case it is still unsafe because you can pass bottom as the first arg and the program will not loop but will instead perform the wrong coercion. In this way you can test your program with the safe but slow mode, and then turn to the unsafe mode and pray your "proofs" were always terminating.