Free-Alternative.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- Test for isomorphism

import Control.Alternative.Free
import Control.Monad
import Test.QuickCheck
import Control.Applicative

data TestCase a = TLift (a)
                | TPure Bool
                | TApXor (TestCase a) (TestCase a)
                | TAlt (TestCase a) (TestCase a)
                | TEmpty deriving (Show)

instance (Arbitrary a) => Arbitrary (TestCase a) where
  arbitrary = sized $ make
              where
                make 0 = leaf 0
                make d = frequency [(1,leaf d),(3,node d)]

                leaf d = frequency
                         [(1, return TEmpty),
                          (2, liftM TLift (resize (d-1) arbitrary)),
                          (1, liftM TPure arbitrary)]

                node d = let smaller = make (d `div` 2) in
                         frequency
                             [(1, liftM2 TAlt smaller smaller),
                              (1, liftM2 TApXor smaller smaller)]

  shrink (TLift x) = (TLift <$> (shrink x))
  shrink (TPure _) = []
  shrink TEmpty    = []
  shrink (TApXor x y) = [x, y] ++ (flip TApXor y <$> shrink x) ++ (TApXor x <$> shrink y)
  shrink (TAlt x y) = [x, y] ++ (flip TAlt y <$> shrink x) ++ (TAlt x <$> shrink y)

evalTest :: Alternative g => (f Bool -> g Bool) -> TestCase (f Bool) -> g Bool
evalTest _ (TEmpty) = empty
evalTest _ (TPure x) = pure x
evalTest lift (TLift f) = lift f
evalTest lift (TApXor x y) = (fmap (/=) (evalTest lift x)) <*> (evalTest lift y)
evalTest lift (TAlt x y) = (evalTest lift x) <|> (evalTest lift y)


isomorphism :: (Alternative f, Eq (f Bool)) => TestCase (f Bool) -> Bool
isomorphism test =
  let a = evalTest id test in
  let b = runAlt id $ evalTest liftAlt test in
  a == b

-- Allows for a weaker version of equality 
weakIsomorphism :: (Alternative f, QuickEq (f Bool)) => TestCase (f Bool) -> Property
weakIsomorphism test =
  let a = evalTest id test in
  let b = runAlt id $ evalTest liftAlt test in
   a `quickEq` b

--- Example with Ziplists
  
newtype ZL a = ZL { foobar :: [a] } deriving (Functor, Show, Arbitrary, Eq)

class QuickEq a where
  boundedEq :: a -> a -> Int -> Bool
  quickEq :: a -> a -> Property
  quickEq a b = forAll (sized (\n -> choose (0,2*n+5))) $ boundedEq a b

instance (Eq a) => QuickEq (ZL a) where
  boundedEq (ZL as) (ZL bs) n = (take n as) == (take n bs)

instance Applicative ZL where
  pure = ZL . repeat
  (ZL as) <*> (ZL bs) = ZL $ zipWith id as bs

instance Alternative ZL where
  empty =  ZL []
  (ZL xs) <|> (ZL ys) = ZL (xs ++ ys)

l3 :: Alt ZL (Integer -> Integer)
l3 = liftAlt $ ZL [id,id,id]

l2 :: Alt ZL (Integer -> Integer)
l2 = liftAlt $ ZL [id,id]

l5 :: Alt ZL (Integer)
l5 = liftAlt $ ZL [1,2,3,4,5]

eval :: Alt ZL a -> ZL a
eval = runAlt id

exp1 = eval $ (l2 <|>  l3) <*>  l5        -- [1,2,1,2,3]
exp2 = (eval l2 <|> eval l3) <*> eval l5  -- [1,2,3,4,5]

weakLeftCatch :: (Alternative f, QuickEq (f Bool)) => Bool -> f Bool -> Property
weakLeftCatch x f = (pure x <|> f) `quickEq` (pure x)

{-
-------
Interesting tests to perform:

quickCheck (weakLeftCatch :: Bool -> (ZL Bool) -> Property)
quickCheck (weakIsomorphism :: TestCase (ZL Bool) -> Property) -- should fail
quickCheck (isomorphism :: TestCase (Maybe Bool) -> Bool)
quickCheck (isomorphism :: TestCase [Bool] -> Bool)
--------
-}