Quickcheck: produce arbitrary elements of an arbitrary set - haskell

Suppose that I am writing tests for Data.Set. I would like to check that deleting elements from the set works, and so I might write something like this:
prop_deleteA it x = member x it ==> not (member x (delete x it))
assuming that it has a suitable Arbitrary instance. However, this relies on quickcheck generating values of x that happen to exist within the set, which is not in general guaranteed. It would be much better if x could be made to depend on it so as to guarantee that x is already a member of it. How might I do this?
I had the thought that I could write
prop_deleteB it f = let x = f it
in not (member x (delete x it))
where f :: Set a -> a is suitably defined by means of coarbitrary. However, coarbitrary would only allow us to define f :: Set a -> b, which unfortunately isn't what we want. My best thought so far has been to define a new type
data SetAndElement a = SetAndElement (Set a) a
which allows us to write a suitable Arbitrary instance
instance (Ord a, Arbitrary a) => Arbitrary (SetAndElement a) where
arbitrary = do it <- suchThat arbitrary (not . Set.null)
x <- elements (elems it)
return (SetAndElement it x)
allowing prop_delete to be written as
prop_deleteC (SetAndElement it x) = not (member x (delete x it))
This works, but seems a little involved; are there any better options? (If not, I'll modify the question and put this as an answer.) The actual Data.Set implementation (containers package) tests deletion by checking that (delete x) . (insert x) == id if x was not already a member of the given set.

It depends on what generators you have available. For example, if you already have setOf1 (generates a Set with at least one element) and setElements (takes elements from a Set), it can be written with forAll:
-- example implementations of both combinators
setOf1 :: (Arbitrary a, Ord a) => Gen a -> Gen (Set a)
setOf1 = fmap fromList . listOf1
setElements :: Set a -> Gen a
setElements = elements . toList
prop_delete =
forAll (setOf1 arbitrary) $ \theSet ->
forAll (setElements theSet) $ \x ->
not (member (x :: Int) (delete x theSet))
This is mostly the same as SetAndElement, but instead of a fixed data type, we're using re-usable functions that can be used for further tests:
prop_null = forAll (setOf1 (arbitrary :: Gen Integer)) $ not . null
However, even if you don't write setOf1 or setElements, forAll can be rather succinct for simple tests:
prop_delete :: (Arbitrary a, Ord a) => (NonEmptyList a) -> Property
prop_delete (NonEmpty xs) =
let theSet = fromList xs
in forAll (elements xs) $ \x ->
not (member x (delete x theSet))
If you provide setElements and NonEmptySet, this can be written as
newtype NonEmptySet x = NonEmptySet {getNonEmptySet :: Set a}
instance (Ord a, Arbitray a) => Arbitrary (NonEmptySet a) where
arbitrary = fmap NonEmptySet . setOf1 $ arbitrary
prop_delete :: (Arbitrary a, Ord a) => (NonEmptySet a) -> Property
prop_delete (NonEmptySet theSet) =
forAll (setElements theSet) $ \x ->
not (member x (delete x theSet))
That way you can use NonEmptySet for tests that require a non-empty set, and setElements only for those where you actually need to choose an element at random.

Related

Is it possible to generate arbitrary functions in QuickCheck

I was trying to write a QuickCheck test for the identity
f $ y = f y
My initial plan was to write an arbitrary generator that returns functions & Integer, having the signature Gen (Int -> Int, Int)
and in the prop_DollerDoesNothing test that function application with / without the $ gives the same result.
This was my code:
prop_DollarDoesNothing :: Property
prop_DollarDoesNothing =
forAll arbitraryFuncInt (\(f, y) -> (f $ y) == (f y))
arbitraryFuncInt :: Gen (Int -> Int, Int)
arbitraryFuncInt = do
f <- elements [(\x -> x*2), (\x -> x+3), (\x -> x-2)]
y <- arbitrary :: Gen Int
return (f, y)
And it generated the following helpful error message:
* No instance for (Show (Int -> Int))
arising from a use of `forAll'
(maybe you haven't applied a function to enough arguments?)
* In the expression:
forAll arbitraryFuncInt (\ (f, y) -> (f $ y) == (f y))
In an equation for `prop_DollarDoesNothing':
prop_DollarDoesNothing
= forAll arbitraryFuncInt (\ (f, y) -> (f $ y) == (f y))
So, I fixed the error and got the test working by applying the arbitrary function and returning a pair of ints from arbitraryFuncInt
prop_DollarDoesNothing :: Property
prop_DollarDoesNothing =
forAll arbitraryFuncInt (\(x, y) -> x == y)
arbitraryFuncInt :: Gen (Int, Int)
arbitraryFuncInt = do
f <- elements [(\x -> x*2), (\x -> x+3), (\x -> x-2)]
y <- arbitrary :: Gen Int
return (f $ y, f y)
My questions are:
is it simply not possible to return arbitrary functions that aren't fully applied due to not having an instance for Show?
Can I write an instance for Show (Int -> Int) to make # 1 possible?
Can QuickCheck generate arbitrary functions given a type signature, for cases where I'm testing identities that are true for all functions (of a given type). Above, I specify the 3 test functions by hand, I'd like to automate that somehow, ideally something like this f <- arbitrary :: Gen (Int -> Int)
QuickCheck has support to generate, shrink and show functions, using the Fun type. CoArbitrary enables generation of functions. It is then converted to a (possibly infinite) trie-like structure, that can be inspected and shrunk to a finite value (because a test failure only depends on finitely many inputs), which can then be shown as a counterexample.
Concretely, you can write properties as function that take a Fun argument, which is a wrapper around (->) using the mechanism I described. Deconstruct it with the Fn pattern to get a function.
prop_dollarDoesNothing :: Property
prop_dollarDoesNothing = property $ \(Fn (f :: Int -> Int)) x ->
(f $ x) === f x
For more information
The QuickCheck implementation: https://hackage.haskell.org/package/QuickCheck-2.11.3/docs/Test-QuickCheck-Function.html
The paper "Shrinking and showing functions" by Koen Claessen, which appears to be paywalled, but his talk is online: https://www.youtube.com/watch?v=CH8UQJiv9Q4
Arbitrary can generate functions just fine (provided the arguments are instances of CoArbitrary), it's just the showing part that doesn't work. There's not really a good way to show a function.
This is a common problem, and therefore QuickCheck provides the Blind modifier. It basically fakes a Show instances for any type, not actually showing any information about the value. Of course this somewhat diminishes the debugging-usefulness of a failing test case, but there's not much that can done about this.

Analog of `<<%~` not requiring Monoid for Traversal

I need a function like <<%~ which would act with Traversals in similar fashion to ^?, like this:
(<<?%~) :: Traversal s t a b -> (a -> b) -> s -> (Maybe a, t)
> ix 0 <<?%~ succ $ [1,2]
(Just 1,[2,2])
> ix 1 <<?%~ succ $ [1,2]
(Just 2,[1,3])
> ix 2 <<?%~ succ $ [1,2]
(Nothing,[1,2])
How should I implement it? The obvious way is to apply ^? and %~ separately, but I'd like a solution in one go.
If we don't want to require a Monoid constraint on the targets, we have to specify ourselves the Monoid that will be used for combining the old elements in a traversal. As the goal is something analogous to ^?, the appropriate monoid is First.
(<<?%~) :: LensLike ((,) (First a)) s t a b -> (a -> b) -> s -> (Maybe a, t)
l <<?%~ f = first getFirst . (l $ \a -> (First (Just a), f a))

How can I test functions polymorphic over Applicatives?

I've just written a function (for Data.Sequence)
traverseWithIndex :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)
which should obey
traverseWithIndex f = sequenceA . mapWithIndex f
Thankfully, this is a straightforward mechanical modification of the source of mapWithIndex, so I am quite confident it is correct. However, in more complex cases thorough testing would be required. I'm trying to write a QuickCheck property to test this simple one. Obviously, I can't try it out with every Applicative functor! When testing monoids, it makes good sense to test with the free monoid over (i.e., finite lists of) some type. So it seems sensible here to test with the free applicative functor over some functor. There are two difficulties:
How do I choose an appropriate base functor? I presumably want a nasty one that isn't applicative or traversable or anything, but such a thing seems likely hard to work with.
How do I compare the results? They'll have functions in them, so they have no Eq instance.
Here's a partial(?) solution. The main aspects we want to check are 1) obviously the same value is computed, and 2) the effects are performed in the same order. I think the following code is self-explanatory enough:
{-# LANGUAGE FlexibleInstances #-}
module Main where
import Control.Applicative
import Control.Applicative.Free
import Data.Foldable
import Data.Functor.Identity
import Test.QuickCheck
import Text.Show.Functions -- for Show instance for function types
data Fork a = F a | G a deriving (Eq, Show)
toIdentity :: Fork a -> Identity a
toIdentity (F a) = Identity a
toIdentity (G a) = Identity a
instance Functor Fork where
fmap f (F a) = F (f a)
fmap f (G a) = G (f a)
instance (Arbitrary a) => Arbitrary (Fork a) where
arbitrary = elements [F,G] <*> arbitrary
instance (Arbitrary a) => Arbitrary (Ap Fork a) where
arbitrary = oneof [Pure <$> arbitrary,
Ap <$> (arbitrary :: Gen (Fork Int)) <*> arbitrary]
effectOrder :: Ap Fork a -> [Fork ()]
effectOrder (Pure _) = []
effectOrder (Ap x f) = fmap (const ()) x : effectOrder f
value :: Ap Fork a -> a
value = runIdentity . runAp toIdentity
checkApplicative :: (Eq a) => Ap Fork a -> Ap Fork a -> Bool
checkApplicative x y = effectOrder x == effectOrder y && value x == value y
succeedingExample = quickCheck (\f x -> checkApplicative
(traverse (f :: Int -> Ap Fork Int) (x :: [Int]))
(sequenceA (fmap f x)))
-- note reverse
failingExample = quickCheck (\f x -> checkApplicative
(traverse (f :: Int -> Ap Fork Int) (reverse x :: [Int]))
(sequenceA (fmap f x)))
-- instance just for example, could make a more informative one
instance Show (Ap Fork Int) where show _ = "<Ap>"
-- values match ...
betterSucceedingExample = quickCheck (\x ->
value (sequenceA (x :: [Ap Fork Int]))
== value (fmap reverse (sequenceA (reverse x))))
-- but effects don't.
betterFailingExample = quickCheck (\x -> checkApplicative
(sequenceA (x :: [Ap Fork Int]))
(fmap reverse (sequenceA (reverse x))))
The output looks like:
*Main Text.Show.Functions> succeedingExample
+++ OK, passed 100 tests.
*Main Text.Show.Functions> failingExample
*** Failed! Falsifiable (after 3 tests and 2 shrinks):
<function>
[0,1]
*Main Text.Show.Functions> betterSucceedingExample
+++ OK, passed 100 tests.
*Main Text.Show.Functions> betterFailingExample
*** Failed! Falsifiable (after 10 tests and 1 shrink):
[<Ap>,<Ap>]
Obviously, I can't try it out with every Applicative functor!
I'm reminded of this blog post series, which I won't claim to fully understand:
http://comonad.com/reader/2012/abstracting-with-applicatives/
http://comonad.com/reader/2013/algebras-of-applicatives/
The lesson that I recall drawing from this is that nearly every applicative functor you see in the wild turns out to be the composition, product or (restricted) coproduct of simpler ones like these (not meant to be exhaustive):
Const
Identity
(->)
So while you can't try it out with every Applicative functor, there are inductive arguments that you might be able to exploit in QuickCheck properties to gain confidence that your function works for large inductively-defined families of functors. So for example you could test:
Your function works correctly for the "atomic" applicatives of your choice;
If your function works correctly for functors f and g, it works correctly for Compose f g, Product f g and Coproduct f g.
How do I compare the results? They'll have functions in them, so they have no Eq instance.
Well, I think you may have to look at QuickCheck testing of function equality. Last time I had to do something along those lines I went with Conal's checkers library, which has an EqProp class for "[t]ypes of values that can be tested for equality, perhaps through random sampling." This should give you an idea already—even if you don't have an Eq instance for functions, QuickCheck may be capable of proving that two functions are unequal. Critically, this instance exists:
instance (Show a, Arbitrary a, EqProp b) => EqProp (a -> b)
...and any type that has an Eq instance has a trivial EqProp instance where (=-=) = (==).
So that suggests, to my mind, using Coyoneda Something as the base functor, and figuring out how to plug together all the little functions.

Monoid mempty in pattern matching

I tried to write a generalized maximum function similar to the one in Prelude. My first naiv approach looked like this:
maximum' :: (F.Foldable a, Ord b) => a b -> Maybe b
maximum' mempty = Nothing
maximum' xs = Just $ F.foldl1 max xs
However, when I test it it always returns Nothing regardless of the input:
> maximum' [1,2,3]
> Nothing
Now I wonder whether it's possible to obtain the empty value of a Monoid type instance. A test function I wrote works correctly:
getMempty :: (Monoid a) => a -> a
getMempty _ = mempty
> getMempty [1,2,3]
> []
I had already a look at these two questions but I didn't figure out how the answers solve my problem:
Write a Maximum Monoid using Maybe in Haskell
Haskell Pattern Matching on the Empty Set
How would I rewrite the maximum' function to get it to work ?
As C. A. McCann points out in his comment, you can't pattern match on values, only patterns.
The equation maximum' mempty = Nothing is actually equivalent to the equation maximum' x = Nothing. The argument gets bound to a name and Nothing is returned.
Here's a way to make your code work:
maximum' :: (F.Foldable a, Ord b, Eq (a b), Monoid (a b)) => a b -> Maybe b
maximum' xs
| xs == mempty = Nothing
| otherwise = Just $ F.foldl1 max xs
I.e. you can compare the value xs against mempty. Note that we need a Monoid constraint to be able to get at the value mempty :: a b and an Eq constraint to be able to compare as well.
An other, more elegant, solution would be to use a fold to differentiate between the empty and non-empty cases:
maximum'' :: (F.Foldable a, Ord b) => a b -> Maybe b
maximum'' xs = F.foldl max' Nothing xs
where max' Nothing x = Just x
max' (Just y) x = Just $ max x y
There are a few ways to do this (the one #opqdonut demonstrates is good). One could also make a "maximum" monoid around Maybe, and use foldMap.
newtype Maximum a = Max { unMaximum :: Maybe a }
instance (Ord a) => Monoid (Maximum a) where
mempty = Max Nothing
mappend (Max Nothing) b = b
mappend a (Max Nothing) = a
mappend (Max (Just a)) (Max (Just b)) = Max . Just $ (max a b)
maximum' = unMaximum . F.foldMap (Max . Just)
There are many ways, one is (as you mention) to create an instance of Monoid. However, we need to wrap it to Maybe to distinguish the case when we have no values. The implementation might look like this:
import Data.Monoid (Monoid, mempty, mappend)
import qualified Data.Foldable as F
-- Either we have a maximum value, or Nothing, if the
-- set of values is empty.
newtype Maximum a = Maximum { getMaximum :: Maybe a }
deriving (Eq, Ord, Read, Show)
instance Ord a => Monoid (Maximum a) where
mempty = Maximum Nothing
-- If one part is Nothing, just take the other one.
-- If both have a value, take their maximum.
(Maximum Nothing) `mappend` y = y
x `mappend` (Maximum Nothing) = x
(Maximum (Just x)) `mappend` (Maximum (Just y))
= Maximum (Just $ x `max` y)
maximum' :: (F.Foldable t, Ord a) => t a -> Maximum a
maximum' = F.foldMap (Maximum . Just)
As many have already told you, you can't pattern match on a value.
As fewer people have told you, pattern matching is arguably the Haskell equivalent of object fields in a language like Java: it's valuable for internal consumption by tightly coupled code, but probably not something you wish to expose to external client code. Basically, if you let a piece of code know your type's constructors, now you can never change these constructors without changing that other piece of code—even if your type's semantics did not really change.
The best solution here is really to just use Foldable.foldr:
maximum' :: (F.Foldable a, Ord b) => a b -> Maybe b
maximum' = F.foldr step Nothing
where step x Nothing = Just x
step x (Just y) = Just (max x y)
Note that foldr is a generalized destructor or eliminator for Foldable instances: its two arguments are "what to do with a non-empty Foldable" and "what to do with mempty. This is more abstract and reusable than pattern matching.
How about
maximum' :: (Monoid (t a), F.Foldable t, Ord a, Eq (t a)) => t a -> Maybe a
maximum' xs
| xs == mempty = Nothing
| otherwise = Just $ F.foldl1 max xs
You were missing a guard.
On the getEmpty function, you don't need it. Just use mempty, and allow its type to be inferred.

Constructing efficient monad instances on `Set` (and other containers with constraints) using the continuation monad

Set, similarly to [] has a perfectly defined monadic operations. The problem is that they require that the values satisfy Ord constraint, and so it's impossible to define return and >>= without any constraints. The same problem applies to many other data structures that require some kind of constraints on possible values.
The standard trick (suggested to me in a haskell-cafe post) is to wrap Set into the continuation monad. ContT doesn't care if the underlying type functor has any constraints. The constraints become only needed when wrapping/unwrapping Sets into/from continuations:
import Control.Monad.Cont
import Data.Foldable (foldrM)
import Data.Set
setReturn :: a -> Set a
setReturn = singleton
setBind :: (Ord b) => Set a -> (a -> Set b) -> Set b
setBind set f = foldl' (\s -> union s . f) empty set
type SetM r a = ContT r Set a
fromSet :: (Ord r) => Set a -> SetM r a
fromSet = ContT . setBind
toSet :: SetM r r -> Set r
toSet c = runContT c setReturn
This works as needed. For example, we can simulate a non-deterministic function that either increases its argument by 1 or leaves it intact:
step :: (Ord r) => Int -> SetM r Int
step i = fromSet $ fromList [i, i + 1]
-- repeated application of step:
stepN :: Int -> Int -> Set Int
stepN times start = toSet $ foldrM ($) start (replicate times step)
Indeed, stepN 5 0 yields fromList [0,1,2,3,4,5]. If we used [] monad instead, we would get
[0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4,1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5]
instead.
The problem is efficiency. If we call stepN 20 0 the output takes a few seconds and stepN 30 0 doesn't finish within a reasonable amount of time. It turns out that all Set.union operations are performed at the end, instead of performing them after each monadic computation. The result is that exponentially many Sets are constructed and unioned only at the end, which is unacceptable for most tasks.
Is there any way around it, to make this construction efficient? I tried but without success.
(I even suspect that there could be some kinds of theoretical limits following from Curry-Howard isomorphism and Glivenko's theorem. Glivenko's theorem says that for any propositional tautology φ the formula ¬¬φ can be proved in intuitionistic logic. However, I suspect that the length of the proof (in normal form) can be exponentially long. So, perhaps, there could be cases when wrapping a computation into the continuation monad will make it exponentially longer?)
Monads are one particular way of structuring and sequencing computations. The bind of a monad cannot magically restructure your computation so as to happen in a more efficient way. There are two problems with the way you structure your computation.
When evaluating stepN 20 0, the result of step 0 will be computed 20 times. This is because each step of the computation produces 0 as one alternative, which is then fed to the next step, which also produces 0 as alternative, and so on...
Perhaps a bit of memoization here can help.
A much bigger problem is the effect of ContT on the structure of your computation. With a bit of equational reasoning, expanding out the result of replicate 20 step, the definition of foldrM and simplifying as many times as necessary, we can see that stepN 20 0 is equivalent to:
(...(return 0 >>= step) >>= step) >>= step) >>= ...)
All parentheses of this expression associate to the left. That's great, because it means that the RHS of each occurrence of (>>=) is an elementary computation, namely step, rather than a composed one. However, zooming in on the definition of (>>=) for ContT,
m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c)
we see that when evaluating a chain of (>>=) associating to the left, each bind will push a new computation onto the current continuation c. To illustrate what is going on, we can use again a bit of equational reasoning, expanding out this definition for (>>=) and the definition for runContT, and simplifying, yielding:
setReturn 0 `setBind`
(\x1 -> step x1 `setBind`
(\x2 -> step x2 `setBind` (\x3 -> ...)...)
Now, for each occurrence of setBind, let's ask ourselves what the RHS argument is. For the leftmost occurrence, the RHS argument is the whole rest of the computation after setReturn 0. For the second occurrence, it's everything after step x1, etc. Let's zoom in to the definition of setBind:
setBind set f = foldl' (\s -> union s . f) empty set
Here f represents all the rest of the computation, everything on the right hand side of an occurrence of setBind. That means that at each step, we are capturing the rest of the computation as f, and applying f as many times as there are elements in set. The computations are not elementary as before, but rather composed, and these computations will be duplicated many times.
The crux of the problem is that the ContT monad transformer is transforming the initial structure of the computation, which you meant as a left associative chain of setBind's, into a computation with a different structure, ie a right associative chain. This is after all perfectly fine, because one of the monad laws says that, for every m, f and g we have
(m >>= f) >>= g = m >>= (\x -> f x >>= g)
However, the monad laws do not impose that the complexity remain the same on each side of the equations of each law. And indeed, in this case, the left associative way of structuring this computation is a lot more efficient. The left associative chain of setBind's evaluates in no time, because only elementary subcomputations are duplicated.
It turns out that other solutions shoehorning Set into a monad also suffer from the same problem. In particular, the set-monad package, yields similar runtimes. The reason being, that it too, rewrites left associative expressions into right associative ones.
I think you have put the finger on a very important yet rather subtle problem with insisting that Set obeys a Monad interface. And I don't think it can be solved. The problem is that the type of the bind of a monad needs to be
(>>=) :: m a -> (a -> m b) -> m b
ie no class constraint allowed on either a or b. That means that we cannot nest binds on the left, without first invoking the monad laws to rewrite into a right associative chain. Here's why: given (m >>= f) >>= g, the type of the computation (m >>= f) is of the form m b. A value of the computation (m >>= f) is of type b. But because we can't hang any class constraint onto the type variable b, we can't know that the value we got satisfies an Ord constraint, and therefore cannot use this value as the element of a set on which we want to be able to compute union's.
Recently on Haskell Cafe Oleg gave an example how to implement the Set monad efficiently. Quoting:
... And yet, the efficient genuine Set monad is possible.
...
Enclosed is the efficient genuine Set monad. I wrote it in direct style (it seems to be faster, anyway). The key is to use the optimized choose function when we can.
{-# LANGUAGE GADTs, TypeSynonymInstances, FlexibleInstances #-}
module SetMonadOpt where
import qualified Data.Set as S
import Control.Monad
data SetMonad a where
SMOrd :: Ord a => S.Set a -> SetMonad a
SMAny :: [a] -> SetMonad a
instance Monad SetMonad where
return x = SMAny [x]
m >>= f = collect . map f $ toList m
toList :: SetMonad a -> [a]
toList (SMOrd x) = S.toList x
toList (SMAny x) = x
collect :: [SetMonad a] -> SetMonad a
collect [] = SMAny []
collect [x] = x
collect ((SMOrd x):t) = case collect t of
SMOrd y -> SMOrd (S.union x y)
SMAny y -> SMOrd (S.union x (S.fromList y))
collect ((SMAny x):t) = case collect t of
SMOrd y -> SMOrd (S.union y (S.fromList x))
SMAny y -> SMAny (x ++ y)
runSet :: Ord a => SetMonad a -> S.Set a
runSet (SMOrd x) = x
runSet (SMAny x) = S.fromList x
instance MonadPlus SetMonad where
mzero = SMAny []
mplus (SMAny x) (SMAny y) = SMAny (x ++ y)
mplus (SMAny x) (SMOrd y) = SMOrd (S.union y (S.fromList x))
mplus (SMOrd x) (SMAny y) = SMOrd (S.union x (S.fromList y))
mplus (SMOrd x) (SMOrd y) = SMOrd (S.union x y)
choose :: MonadPlus m => [a] -> m a
choose = msum . map return
test1 = runSet (do
n1 <- choose [1..5]
n2 <- choose [1..5]
let n = n1 + n2
guard $ n < 7
return n)
-- fromList [2,3,4,5,6]
-- Values to choose from might be higher-order or actions
test1' = runSet (do
n1 <- choose . map return $ [1..5]
n2 <- choose . map return $ [1..5]
n <- liftM2 (+) n1 n2
guard $ n < 7
return n)
-- fromList [2,3,4,5,6]
test2 = runSet (do
i <- choose [1..10]
j <- choose [1..10]
k <- choose [1..10]
guard $ i*i + j*j == k * k
return (i,j,k))
-- fromList [(3,4,5),(4,3,5),(6,8,10),(8,6,10)]
test3 = runSet (do
i <- choose [1..10]
j <- choose [1..10]
k <- choose [1..10]
guard $ i*i + j*j == k * k
return k)
-- fromList [5,10]
-- Test by Petr Pudlak
-- First, general, unoptimal case
step :: (MonadPlus m) => Int -> m Int
step i = choose [i, i + 1]
-- repeated application of step on 0:
stepN :: Int -> S.Set Int
stepN = runSet . f
where
f 0 = return 0
f n = f (n-1) >>= step
-- it works, but clearly exponential
{-
*SetMonad> stepN 14
fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14]
(0.09 secs, 31465384 bytes)
*SetMonad> stepN 15
fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15]
(0.18 secs, 62421208 bytes)
*SetMonad> stepN 16
fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16]
(0.35 secs, 124876704 bytes)
-}
-- And now the optimization
chooseOrd :: Ord a => [a] -> SetMonad a
chooseOrd x = SMOrd (S.fromList x)
stepOpt :: Int -> SetMonad Int
stepOpt i = chooseOrd [i, i + 1]
-- repeated application of step on 0:
stepNOpt :: Int -> S.Set Int
stepNOpt = runSet . f
where
f 0 = return 0
f n = f (n-1) >>= stepOpt
{-
stepNOpt 14
fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14]
(0.00 secs, 515792 bytes)
stepNOpt 15
fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15]
(0.00 secs, 515680 bytes)
stepNOpt 16
fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16]
(0.00 secs, 515656 bytes)
stepNOpt 30
fromList [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30]
(0.00 secs, 1068856 bytes)
-}
I don't think your performance problems in this case are due to the use of Cont
step' :: Int -> Set Int
step' i = fromList [i,i + 1]
foldrM' f z0 xs = Prelude.foldl f' setReturn xs z0
where f' k x z = f x z `setBind` k
stepN' :: Int -> Int -> Set Int
stepN' times start = foldrM' ($) start (replicate times step')
gets similar performance to the Cont based implementation but occurs entirely in the Set "restricted monad"
I am not sure if I believe your claim about Glivenko's theorem leading to exponential increase in (normalized) proof size--at least in the Call-By-Need context. That is because we can arbitrarily reuse subproofs (and our logic is second order, we need only a single proof of forall a. ~~(a \/ ~a)). Proofs are not trees, they are graphs (sharing).
In general, you are likely to see performance costs from Cont wrapping Set but they can usually be avoided via
smash :: (Ord r, Ord k) => SetM r r -> SetM k r
smash = fromSet . toSet
I found out another possibility, based on GHC's ConstraintKinds extension. The idea is to redefine Monad so that it includes a parametric constraint on allowed values:
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RebindableSyntax #-}
import qualified Data.Foldable as F
import qualified Data.Set as S
import Prelude hiding (Monad(..), Functor(..))
class CFunctor m where
-- Each instance defines a constraint it valust must satisfy:
type Constraint m a
-- The default is no constraints.
type Constraint m a = ()
fmap :: (Constraint m a, Constraint m b) => (a -> b) -> (m a -> m b)
class CFunctor m => CMonad (m :: * -> *) where
return :: (Constraint m a) => a -> m a
(>>=) :: (Constraint m a, Constraint m b) => m a -> (a -> m b) -> m b
fail :: String -> m a
fail = error
-- [] instance
instance CFunctor [] where
fmap = map
instance CMonad [] where
return = (: [])
(>>=) = flip concatMap
-- Set instance
instance CFunctor S.Set where
-- Sets need Ord.
type Constraint S.Set a = Ord a
fmap = S.map
instance CMonad S.Set where
return = S.singleton
(>>=) = flip F.foldMap
-- Example:
-- prints fromList [3,4,5]
main = print $ do
x <- S.fromList [1,2]
y <- S.fromList [2,3]
return $ x + y
(The problem with this approach is in the case the monadic values are functions, such as m (a -> b), because they can't satisfy constraints like Ord (a -> b). So one can't use combinators like <*> (or ap) for this constrained Set monad.)

Resources