ShrinkOnce.hs

ApplicativeLaw

Applicative laws (in terms of 'prod'):

prod :: Applicative f => f a -> f b -> f (a,b)
prod = liftA2 (,)

(1) Left unit:

    pure a `prod` fb = fmap (a,) fb

    pure a `prod` Once b bs
      = liftA2 (,) (Once a []) (Once b bs)
      = Once (a,b) (fmap (a,) bs ++ fmap (,b) [])
      = Once (a,b) (fmap (a,) bs)
      = fmap (a,) (Once b bs)

(2) Right unit:

    fa `prod` pure b = fmap (,b) fa

    Once a as `prod` pure b =
      = liftA2 (,) (Once a as) (Once b [])
      = Once (a,b) (fmap (a,) [] ++ fmap (,b) as)
      = Once (a,b) (fmap (,b) as)
      = fmap (,b) (Once a as)

(3) Associativity: 

    fa `prod` (fb `prod` fc) = assoc <$> (fa `prod` fb) `prod` fc
      where assoc ((a,b),c) = (a,(b,c))

    Once a as `prod` (Once b bs `prod` Once c cs)
      = Once a as `prod` (Once (b,c) (fmap (b,) cs ++ fmap (,c) bs))
      = Once (a,(b,c)) (fmap (a,) (fmap (b,) cs ++ fmap (,c) bs) ++
                        fmap (,(b,c)) as)
      = Once (a,(b,c)) (fmap (a,(b,)) cs ++ fmap (a,(,c)) bs ++
                        fmap (,(b,c)) as)

    (Once a as `prod` Once b bs) `prod` Once c cs
      = (Once (a,b) (fmap (a,) bs ++ fmap (,b) as)) `prod` Once c cs
      = Once ((a,b),c) (fmap ((a,b),) cs ++
                        fmap (,c) (fmap (a,) bs ++ fmap (,b) as))
      = Once ((a,b),c) (fmap ((a,b),) cs ++ fmap ((a,),c) bs ++
                        fmap ((,b),c) as)

Examples

> fmap sum $ sequenceA [[0,8], [0,4], [0,2], [0,1]]
[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15]
> fmap sum $ sequenceA [Once 0 [8], Once 0 [4], Once 0 [2], Once 0 [1]]
Once {getDefault = 0, getVariants = [1,2,4,8]}
> :{
*ShrinkOnce| do a <- Once 0 [1,2]
*ShrinkOnce|    b <- Once 0 [1,2]
*ShrinkOnce|    let c0 = a + b
*ShrinkOnce|    c <- Once c0 [c0+1]
*ShrinkOnce|    return (a,b,c)
*ShrinkOnce| :}
Once {getDefault = (0,0,0), getVariants = [(0,0,1),(0,1,1),(0,2,2),(1,0,1),(2,0,2)]}

ShrinkOnce.hs

{-# LANGUAGE DeriveFunctor #-}
module ShrinkOnce(
  Once(..),
  shrinkOnce
) where

import Control.Applicative

data Once a = Once { getDefault :: a
                   , getVariants :: [a] }
  deriving (Show, Read, Eq, Ord, Functor)

instance Applicative Once where
  pure a = Once a []
  liftA2 op (Once a as) (Once b bs) =
    Once (a `op` b) (fmap (a `op`) bs ++ fmap (`op` b) as)

instance Monad Once where
  return = pure
  Once a as >>= k =
    let Once b bs1 = k a
        bs2 = getDefault . k <$> as
    in Once b (bs1 ++ bs2)

-- | Apply shrinking function to one of elements of a traversable container.
shrinkOnce :: (Traversable t) => (a -> [a]) -> t a -> [t a]
shrinkOnce f = getVariants . traverse (\a -> Once a (f a))