Cartesian product of heterogeneous lists - haskell

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

Related

Is FlexibleContexts really needed in this context?

The question I posted makes no sense.
The type signatures were provided by ghci.
I misread it: not (MonadReader (Map k (Set a -> Set a)) m;
but rather: MonadReader (Map k (Set a -> Set a) m).
It was just an oversight. Sorry for wasting your time.
========================================
Is FlexibleContexts really needed in this context?
Which monad does "m" stand for?
I tried replacing "m" with [ ], but it didn't work.
{-# LANGUAGE FlexibleContexts #-}
module LeftCensorsList where
import Data.Set as S
import Data.Map as M
import Data.List as L
import Control.Monad.Reader
-- ============================== FUNCTIONS ==============================
censorsList :: Ord a => Map a (Set a -> Set a) -> [Set a] -> ([Set a], [Set a])
censorsList _ [] = ([],[])
censorsList cnsrmap (xs:xss) = runReader (go xs xss [xs]) cnsrmap
where
go _ [] invacc = pure (reverse invacc,[])
go cnsrs (ys:yss) invacc = do
ys' <- applyCensors cnsrs ys
if S.null ys'
then pure (reverse invacc,ys:yss)
else go ys' yss (ys': invacc)
applyCensors :: (MonadReader (Map k (Set a -> Set a)) m, Ord k) => Set k -> Set a -> m (Set a) -- <<<<<
applyCensors cnsrs xs = go (S.toList cnsrs) xs
where
go [] ys = pure ys
go (cnsr:rest) ys = do
ys' <- applyCensor cnsr ys
if S.null ys'
then pure S.empty
else go rest ys'
applyCensor :: (MonadReader (Map k (t -> t)) m, Ord k) => k -> t -> m t -- <<<<<
applyCensor cnsr xs = do
cnsrmap <- ask
case M.lookup cnsr cnsrmap of
Nothing -> pure xs
Just f -> pure $ f xs
-- ============================== TEST ==============================
t1,t2,t3, t4 :: ([Set Int],[Set Int])
t1 = censorsList M.empty $ L.map S.fromList [[1,3,13],[2,4,6]] -- ok
t2 = censorsList exCensorsMap $ L.map S.fromList [[1,3,13],[2,4,6]] -- ok
t3 = censorsList exCensorsMap [] -- ok
t4 = censorsList exCensorsMap $ L.map S.fromList [[1,4,13],[2,4,5]] -- ok
-- ============================== EXAMPLES ==============================
-- -------------------- MAPS --------------------
exCensorsMap :: Map Int (Set Int -> Set Int)
exCensorsMap = M.fromList $
[(1,censor1)
,(2,censor2)
,(3,censor3)
,(4,censor4)
]
-- -------------------- CENSORS --------------------
censor1, censor2, censor3, censor4 :: Set Int -> Set Int
censor1 = \xs -> xs S.\\ (S.fromList [2,4])
censor2 = \xs -> xs S.\\ (S.fromList [3])
censor3 = \xs -> xs S.\\ (S.fromList [1,2])
censor4 = \xs -> xs S.\\ (S.fromList [2,5])
The monad you are instantiating is the reader monad:
applyCensors :: (Ord k) => Set k -> Set a -> Reader (Map k (Set a -> Set a)) (Set a)
You can infer this yourself by noting the type of runReader and unifying from there.
The type signatures were provided by ghci.
I misread it: not (MonadReader (Map k (Set a -> Set a)) m;
but rather: MonadReader (Map k (Set a -> Set a) m).
It was just an oversight and therefore the question makes no sense.
Sorry for wasting your time.

Getting the last element of a heterogeneous list

I'm trying to define a function (hLast) that returns the last element of a heterogenous list:
type family HLastR xs where
HLastR '[x] = x
HLastR (x ': xs) = HLastR xs
class HLast xs where
hLast :: HList xs -> HLastR xs
instance HLast '[x] where
hLast (x `HCons` HNil) = x
instance (HLast xs, HLastR xs ~ HLastR (x ': xs)) => HLast (x ': xs) where
hLast (x `HCons` xs) = hLast xs
With this code, GHC always complains that there are overlapping instances for HLast. I don't understand how the instances could ever overlap: An HList of more than one element only matches the second instance and singletons should only match the first instance since the second instance requires an HLast instance for the tail (HNil in the singleton case, for which there is no instance).
Adding an {-# OVERLAPPING #-} directive to the first instance solves the problem, but this feels like an overly hacky solution for such a simple problem. Is there a better way to do this? Thanks!
Assuming HList is defined as a GADT, you don't need a type class in the first place.
data HList xs where
HCons :: x -> HList xs -> HList (x ': xs)
HNil :: HList '[]
type family HLastR xs where
HLastR '[x] = x
HLastR (x ': xs) = HLastR xs
hlast :: HList xs -> HLastR xs
hlast (HCons x HNil) = x
hlast (HCons _ xs#(HCons _ _)) = hlast xs

Splitting a type-level list in GHC

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.

Is it possible to represent this transformation in a strongly typed manner?

I'm looking to perform a transformation like (in F#):
type Test = TBool of bool | TString of string
type TestList = TLBool of bool list | TLString of string list
let transform : Map<int, Test> list -> Map<int, TestList> = ??
Is there a way to encode this such that we "know" that while the Map contains heterogeneous values, the value at each position is the same type across elements of the containing list? The Maps would be of static size once constructed and the same across each list element, but the size is not known in advance so I'm basically looking to generate tuples/records of an unknown size.
Edit
I think my example was unclear. The root of what I'm after is to be able to take two variable sized collections whose values at a given position are always the same type, but that the collection itself can contain values of multiple types, and "zip" them together using the knowledge that at a given position the two values are the same type. Specifically, I don't want to have to recheck that they are the same and propagate the condition that they vary (as an error of some sort), since I already do exactly that when initially creating the collections.
Edit 2
From a comment posted below: I do essentially want heterogenous lists (I used maps since my indices can be sparse, but I could always use lists with an index mapping), but with the additional constraint that two instances of the heterogenous list can be "zipped together" and the values at a given index are of the same type.
Edit [...] The root of what I'm after is to be able to take two variable sized collections whose values at a given position are always the same type, but that the collection itself can contain values of multiple types, and "zip" them together using the knowledge that at a given position the two values are the same type.
This, in its broadest reading, fundamentally requires that the types of the collections encode which position contains which element type, and this dips into dependent types territory.
If there is one fixed shape of collection that can be determined at compilation time, however, then it's easy—you just write a type all of whose values have that shape.
You could define a transformMap function that has the property you want (i.e. preserves the key and turns strings to lists of strings and bools to lists of bools). The function can still be fully parametric in what it does with the values:
let transformMap fstr fbool map =
map |> Map.map (fun k v ->
match v with
| TBool b -> TLBool(fbool k b)
| TString s -> TLString(fstr k s) )
Any transformation that you then perform on your map using transformMap has the properties you want. If you wanted to be more strict, you could write a wrapper over Map<'K, TestList> and hide the internal representation, which would give you a strong guarantee. In practice, I think it is probably reasonable to make the internals public, but check by hand that you only manipulate the map using your correct transformation function.
An example that turns each value into a singleton list using this function looks like this:
Map.empty |> transformMap
(fun k s -> [s])
(fun k b -> [b])
If you can do with Test list instead of TestList, the conversion is fairly straightforward:
let transform listOfMaps : Map<int, Test list> =
listOfMaps
|> Seq.collect Map.toSeq
|> Seq.groupBy fst
|> Seq.map (fun (i, s) ->
let xs = s |> Seq.map snd |> Seq.toList
i, xs)
|> Map.ofSeq
As far as capturing your assumptions in the types, I suspect it's either impossible or much more effort than it's worth.
Heterogeneous lists with elements wrapped in some f are:
{-# LANGUAGE GADTs, DataKinds, TypeOperators #-}
infixr 5 :::
data HList f as where
HNil :: HList f '[]
(:::) :: f a -> HList f as -> HList f (a ': as)
For example,
xs1 :: HList [] [Bool, Int]
xs1 = [True, False] ::: [1..3] ::: HNil
xs2 :: HList [] [Bool, Int]
xs2 = [True] ::: [1..5] ::: HNil
It's easy to zip two HList []:
hzip :: HList [] as -> HList [] as -> HList [] as
hzip HNil HNil = HNil
hzip (xs ::: xss) (ys ::: yss) = (xs ++ ys) ::: hzip xss yss
Or a bit more generally (and with the Rank2Types extension):
hzipWith :: (forall a. f a -> g a -> h a) -> HList f as -> HList g as -> HList h as
hzipWith f HNil HNil = HNil
hzipWith f (x ::: xs) (y ::: ys) = f x y ::: hzipWith f xs ys
hzip :: HList [] as -> HList [] as -> HList [] as
hzip = hzipWith (++)
Then (requires FlexibleInstances and FlexibleContexts)
instance Show (HList f '[]) where
show HNil = "HNil"
instance (Show (f a), Show (HList f as)) => Show (HList f (a ': as)) where
show (x ::: xs) = show x ++ " ::: " ++ show xs
main = print $ hzip xs1 xs2
prints [True,False,True] ::: [1,2,3,1,2,3,4,5] ::: HNil.

How do I constrain QuickCheck when using type synonyms?

I am using QuickCheck to run arbitrary test cases on my code. However, in one portion of my code I have the type synonym:
type Vector = [Double]
I also have a few functions that accept a number of Vectors as input. However, all of these functions require that the Vectors be of the same length.
Is there a way to constrain QuickCheck so that it only generates lists of length n?
A simple solution is to not have an arbitrary instance but instead to do something like
import Test.QuickCheck
import Control.Monad
prop_vec :: Int -> Gen [Double]
prop_vec = flip replicateM arbitrary . abs
prop_addComm :: Int -> Gen Bool
prop_addComm i = do
v <- prop_vec i
u <- prop_vec i
return $ u + v = v + u --assuming you'd added a Num instance for your vectors
There's never a typeclass so you get less helpful failures, but it's simpler to whip up.
You can set constraints with the ==> notation.
an example is:
prop_test xs = minimum xs == (head $ sort xs)
which fails:
*** Failed! Exception: 'Prelude.minimum: empty list' (after 1 test):
[]
now with a constraint:
prop_test xs = not (null xs) ==> minimum xs == (head $ sort xs)
it works:
*Main> quickCheck prop_test
+++ OK, passed 100 tests.
in your case:
prop_test xs ys = length xs == length ys ==> undefined -- whatever you want
The other obvious solution is to generate a list of tuples and unzip them. For example, in ghci:
> let allSameLength (xs:xss) = all (==length xs) (map length xss)
> quickCheck (\xys -> let (xs, ys) = unzip xys in allSameLength [xs, ys])
+++ OK, passed 100 tests.
> :{
| quickCheck (\wxyzs -> let
| (wxs, yzs) = unzip wxyzs
| (ws, xs) = unzip wxs
| (ys, zs) = unzip yzs
| in allSameLength [ws, xs, ys, zs])
| :}
+++ OK, passed 100 tests.
Here's one possibility. We'll define a new class for types that can build a size-dependent random value. Then you can make a type-level list or tree or whatever and declare one Arbitrary instance for these once and for all.
import Control.Monad
import Test.QuickCheck
class SizedArbitrary a where
sizedArbitrary :: Int -> Gen a
instance Arbitrary a => SizedArbitrary [a] where
sizedArbitrary n = replicateM n arbitrary
data Branch a b = a :+ b deriving (Eq, Ord, Show, Read)
instance (SizedArbitrary a, SizedArbitrary b) => SizedArbitrary (Branch a b) where
sizedArbitrary n = liftM2 (:+) (sizedArbitrary n) (sizedArbitrary n)
instance (SizedArbitrary a, SizedArbitrary b) => Arbitrary (Branch a b) where
arbitrary = arbitrarySizedIntegral >>= sizedArbitrary . abs
Then we can load it up in ghci and check out that it works:
*Main> let allSameLength (xs:xss) = all (==length xs) (map length xss)
*Main> quickCheck (\(xs :+ ys) -> allSameLength [xs, ys])
+++ OK, passed 100 tests.
*Main> quickCheck (\(ws :+ xs :+ ys :+ zs) -> allSameLength [ws, xs, ys, zs])
+++ OK, passed 100 tests.

Resources