{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
-- $Header: c:/Source/Haskell/Wrapper/test/Data/Flex/SmallCheck/RCS/Wrap.hs,v 1.9 2011/09/20 23:50:10 dosuser Exp dosuser $

-- | SmallCheck tests for Data.Flex.Wrap

module Data.Flex.SmallCheck.Wrap where

import Test.SmallCheck

{-
import Control.Applicative ((<$>))

import Data.Wrap (result, argument)
-}

import Data.Monoid (Monoid(..))

import Data.Type.Apply (Apply(..))
import Data.Type.Eq (TypeCast)
import Data.Type.TList ((:*:)(..), TNil(..))

import Data.Flex.Wrap
import Data.Flex.Utils (on)

import Data.Flex.Serial.Wrap ()

{-
import Data.Flex.SmallCheck.Instances
-}

data X = X

-- Eq

prop_default_Eq_is_Eq x y = (x == y) == (w x == w y) where
    w = flexiWrap (X :*: TNil)
    types = x :: Bool

prop_explicit_DefaultEq_is_Eq x y = (x == y) == (w x == w y) where
    w = flexiWrap (FWDefaultEq :*: TNil)
    types = x :: Bool

prop_TransparentEq_is_Eq x y = (x == y) == (w x == w y) where
    w = flexiWrap (FWTransparentEq :*: TNil)
    types = x :: Bool

data FWEqFirst = FWEqFirst

instance TypeCast r FWEqFirst => FWEq (FW (FWEqFirst :*: s) a) r

instance Eq a =>
    Apply (FWEquals t (a, b)) FWEqFirst (FW t (a, b) -> FW t (a, b) -> Bool)
  where
    apply _ _ = (==) `on` fst . unFlexiWrap

instance Eq a =>
    Apply (FWNotEquals t (a, b)) FWEqFirst (FW t (a, b) -> FW t (a, b) -> Bool)
  where
    apply _ _ = (/=) `on` fst `on` unFlexiWrap

prop_EqFirst_is_Eq_fst x y = (x `eqFst` y) == (w x == w y) where
    eqFst = (==) `on` fst
    w = flexiWrap (FWEqFirst :*: TNil)
    types = x :: (Bool, Bool)

testEq :: IO ()
testEq = do
    smallCheck 1 prop_default_Eq_is_Eq
    smallCheck 1 prop_explicit_DefaultEq_is_Eq
    smallCheck 1 prop_TransparentEq_is_Eq
    smallCheck 1 prop_EqFirst_is_Eq_fst

-- Ord

prop_default_Ord_is_Ord x y = (x `compare` y) == (w x `compare` w y) where
    w = flexiWrap (X :*: TNil)
    types = x :: Bool

prop_explicit_DefaultOrd_is_Ord x y = (x `compare` y) == (w x `compare` w y)
  where
    w = flexiWrap (FWDefaultOrd :*: TNil)
    types = x :: Bool

prop_TransparentOrd_is_Ord x y = (x `compare` y) == (w x `compare` w y) where
    w = flexiWrap (FWTransparentOrd :*: TNil)
    types = x :: Bool

prop_ReverseOrd_is_reverse_ord x y = (x `compare` y) == (w y `compare` w x)
  where
    w = flexiWrap (FWReverseOrd :*: TNil)
    types = x :: Bool

testOrd :: IO ()
testOrd = do
    smallCheck 1 prop_default_Ord_is_Ord
    smallCheck 1 prop_explicit_DefaultOrd_is_Ord
    smallCheck 1 prop_TransparentOrd_is_Ord
    smallCheck 1 prop_ReverseOrd_is_reverse_ord

-- Show / Read

prop_default_Show_is_Literal x = show (w x) == "FlexiWrap " ++ show x
  where
    w = flexiWrap TNil
    types = x :: Bool

prop_default_Read_is_Literal x = read ("FlexiWrap " ++ show x) == w x
  where
    w = flexiWrap TNil
    types = x :: Bool

prop_explicit_default_Show_is_Literal x = show (w x) == "FlexiWrap " ++ show x
  where
    w = flexiWrap (FWDefaultShowRead :*: TNil)
    types = x :: Bool

prop_explicit_default_Read_is_Literal x = read ("FlexiWrap " ++ show x) == w x
  where
    w = flexiWrap (FWDefaultShowRead :*: TNil)
    types = x :: Bool

prop_Literal_Show_is_Literal x = show (w x) == "FlexiWrap " ++ show x
  where
    w = flexiWrap (FWLiteralShowRead :*: TNil)
    types = x :: Bool

prop_Literal_Read_is_Literal x = read ("FlexiWrap " ++ show x) == w x
  where
    w = flexiWrap (FWLiteralShowRead :*: TNil)
    types = x :: Bool

prop_Transparent_Show_is_Transparent x = show (w x) == show x
  where
    w = flexiWrap (FWTransparentShowRead :*: TNil)
    types = x :: Bool

prop_Transparent_Read_is_Transparent x = read (show x) == w x
  where
    w = flexiWrap (FWTransparentShowRead :*: TNil)
    types = x :: Bool

prop_default_ShowRead_roundtrips x = (read . show) wx == wx
  where
    wx = flexiWrap TNil x
    types = x :: Bool

prop_LiteralShowRead_roundtrips x = (read . show) wx == wx
  where
    wx = flexiWrap (FWLiteralShowRead :*: TNil) x
    types = x :: Bool

prop_TransparentShowRead_roundtrips x = (read . show) wx == wx
  where
    wx = flexiWrap (FWTransparentShowRead :*: TNil) x
    types = x :: Bool

testShowRead :: IO ()
testShowRead = do
    smallCheck 1 prop_default_Show_is_Literal
    smallCheck 1 prop_default_Read_is_Literal
    smallCheck 1 prop_explicit_default_Show_is_Literal
    smallCheck 1 prop_explicit_default_Read_is_Literal
    smallCheck 1 prop_Literal_Show_is_Literal
    smallCheck 1 prop_Literal_Read_is_Literal
    smallCheck 1 prop_Transparent_Show_is_Transparent
    smallCheck 1 prop_Transparent_Read_is_Transparent
    smallCheck 1 prop_default_ShowRead_roundtrips
    smallCheck 1 prop_LiteralShowRead_roundtrips
    smallCheck 1 prop_TransparentShowRead_roundtrips

-- Monoid

prop_DefaultMonoid_mempty_is_transparent = mempty == w me
  where
    w = flexiWrap TNil
    me = mempty :: [Bool]

prop_DefaultMonoid_mappend_is_transparent x y =
    w x `mappend` w y == w (x `mappend` y)
  where
    w = flexiWrap TNil
    types = x :: [Bool]

prop_explicit_DefaultMonoid_mempty_is_transparent = mempty == w me
  where
    w = flexiWrap (FWDefaultMonoid :*: TNil)
    me = mempty :: [Bool]

prop_explicit_DefaultMonoid_mappend_is_transparent x y =
    w x `mappend` w y == w (x `mappend` y)
  where
    w = flexiWrap (FWDefaultMonoid :*: TNil)
    types = x :: [Bool]

prop_TransparentMonoid_mempty_is_transparent = mempty == w me
  where
    w = flexiWrap (FWTransparentMonoid :*: TNil)
    me = mempty :: [Bool]

prop_TransparentMonoid_mappend_is_transparent x y =
    w x `mappend` w y == w (x `mappend` y)
  where
    w = flexiWrap (FWTransparentMonoid :*: TNil)
    types = x :: [Bool]

prop_DualMonoid_mempty_is_dual = mempty == w me
  where
    w = flexiWrap (FWDualMonoid :*: TNil)
    me = mempty :: [Bool]

prop_DualMonoid_mappend_is_dual x y =
    w x `mappend` w y == w (y `mappend` x)
  where
    w = flexiWrap (FWDualMonoid :*: TNil)
    types = x :: [Bool]

f `feq` g = forAll series $ \z -> f z == g z
wfeq = feq `on` unFlexiWrap

prop_EndoMonoid_mempty_is_id = mempty `wfeq` w idb
  where
    w = flexiWrap (FWEndoMonoid :*: TNil)
    idb = id :: Bool -> Bool

prop_EndoMonoid_mappend_is_composition x y =
    (w x `mappend` w y) `wfeq` w (x . y)
  where
    w = flexiWrap (FWEndoMonoid :*: TNil)
    types = x :: Bool -> Bool

prop_AllMonoid_mempty_is_True = mempty == w True
  where
    w = flexiWrap (FWAllMonoid :*: TNil)

prop_AllMonoid_mappend_is_conjunction x y =
    w x `mappend` w y == w (x && y)
  where
    w = flexiWrap (FWAllMonoid :*: TNil)
    types = x :: Bool

prop_DualAllMonoid_mempty_is_True = mempty == w True
  where
    w = flexiWrap (FWDualMonoid :*: FWAllMonoid :*: TNil)

prop_DualAllMonoid_mappend_is_conjunction x y =
    w x `mappend` w y == w (x && y)
  where
    w = flexiWrap (FWDualMonoid :*: FWAllMonoid :*: TNil)
    types = x :: Bool

prop_AnyMonoid_mempty_is_False = mempty == w False
  where
    w = flexiWrap (FWAnyMonoid :*: TNil)

prop_AnyMonoid_mappend_is_disjunction x y =
    w x `mappend` w y == w (x || y)
  where
    w = flexiWrap (FWAnyMonoid :*: TNil)
    types = x :: Bool

prop_DualAnyMonoid_mempty_is_False = mempty == w False
  where
    w = flexiWrap (FWDualMonoid :*: FWAnyMonoid :*: TNil)

prop_SumMonoid_mempty_is_zero = mempty == w z
  where
    w = flexiWrap (FWSumMonoid :*: TNil)
    z = 0 :: Int

prop_SumMonoid_mappend_is_addition x y =
    w x `mappend` w y == w (x + y)
  where
    w = flexiWrap (FWSumMonoid :*: TNil)
    types = x :: Int

prop_DualSumMonoid_mempty_is_zero = mempty == w z
  where
    w = flexiWrap (FWDualMonoid :*: FWSumMonoid :*: TNil)
    z = 0 :: Int

prop_ProductMonoid_mempty_is_one = mempty == w o
  where
    w = flexiWrap (FWProductMonoid :*: TNil)
    o = 1 :: Int

prop_ProductMonoid_mappend_is_multiplication x y =
    w x `mappend` w y == w (x * y)
  where
    w = flexiWrap (FWProductMonoid :*: TNil)
    types = x :: Int

prop_DualProductMonoid_mappend_is_multiplication x y =
    w x `mappend` w y == w (x * y)
  where
    w = flexiWrap (FWDualMonoid :*: FWProductMonoid :*: TNil)
    types = x :: Int

prop_FirstMonoid_mempty_is_Nothing = mempty == w n
  where
    w = flexiWrap (FWFirstMonoid :*: TNil)
    n = Nothing :: Maybe Bool

prop_FirstMonoid_mempty_mappend_is_id x =
    mempty `mappend` x == x
  where
    types = x :: FW (FWFirstMonoid :*: TNil) (Maybe Bool)

prop_FirstMonoid_Just_mappend_is_const x y =
    wx `mappend` y == wx
  where
    w = flexiWrap (FWFirstMonoid :*: TNil)
    wx = w $ Just x
    types = (x :: Bool, y :: FW (FWFirstMonoid :*: TNil) (Maybe Bool))

prop_LastMonoid_mempty_is_Nothing = mempty == w n
  where
    w = flexiWrap (FWLastMonoid :*: TNil)
    n = Nothing :: Maybe Bool

prop_LastMonoid_mappend_mempty_is_id x =
    x `mappend` mempty == x
  where
    types = x :: FW (FWLastMonoid :*: TNil) (Maybe Bool)

prop_LastMonoid_mappend_Just_is_const x y =
    y `mappend` wx == wx
  where
    w = flexiWrap (FWLastMonoid :*: TNil)
    wx = w $ Just x
    types = (x :: Bool, y :: FW (FWLastMonoid :*: TNil) (Maybe Bool))

prop_DualFirstMonoid_mappend_is_Last x y =
    wdf x `mappend` wdf y `uweq` wl x `mappend` wl y
  where
    wdf = flexiWrap (FWDualMonoid :*: FWFirstMonoid :*: TNil)
    wl = flexiWrap (FWLastMonoid :*: TNil)
    infix 4 `uweq`
    uweq u v = unFlexiWrap u == unFlexiWrap v
    types = (x :: Maybe Bool, y :: Maybe Bool)

testMonoid :: IO ()
testMonoid = do
    smallCheck 0 prop_DefaultMonoid_mempty_is_transparent
    smallCheck 1 prop_DefaultMonoid_mappend_is_transparent
    smallCheck 0 prop_explicit_DefaultMonoid_mempty_is_transparent
    smallCheck 1 prop_explicit_DefaultMonoid_mappend_is_transparent
    smallCheck 0 prop_TransparentMonoid_mempty_is_transparent
    smallCheck 1 prop_TransparentMonoid_mappend_is_transparent
    smallCheck 0 prop_DualMonoid_mempty_is_dual
    smallCheck 1 prop_DualMonoid_mappend_is_dual
    smallCheck 0 prop_EndoMonoid_mempty_is_id
    smallCheck 1 prop_EndoMonoid_mappend_is_composition
    smallCheck 0 prop_AllMonoid_mempty_is_True
    smallCheck 1 prop_AllMonoid_mappend_is_conjunction
    smallCheck 0 prop_DualAllMonoid_mempty_is_True
    smallCheck 1 prop_DualAllMonoid_mappend_is_conjunction
    smallCheck 0 prop_AnyMonoid_mempty_is_False
    smallCheck 1 prop_AnyMonoid_mappend_is_disjunction
    smallCheck 0 prop_DualAnyMonoid_mempty_is_False
    smallCheck 0 prop_SumMonoid_mempty_is_zero
    smallCheck 1 prop_SumMonoid_mappend_is_addition
    smallCheck 0 prop_DualSumMonoid_mempty_is_zero
    smallCheck 0 prop_ProductMonoid_mempty_is_one
    smallCheck 1 prop_ProductMonoid_mappend_is_multiplication
    smallCheck 1 prop_DualProductMonoid_mappend_is_multiplication
    smallCheck 0 prop_FirstMonoid_mempty_is_Nothing
    smallCheck 1 prop_FirstMonoid_mempty_mappend_is_id
    smallCheck 1 prop_FirstMonoid_Just_mappend_is_const
    smallCheck 0 prop_LastMonoid_mempty_is_Nothing
    smallCheck 1 prop_LastMonoid_mappend_mempty_is_id
    smallCheck 1 prop_LastMonoid_mappend_Just_is_const
    smallCheck 1 prop_DualFirstMonoid_mappend_is_Last

testAll :: IO ()
testAll = do
    testEq
    testOrd
    testShowRead
    testMonoid

-- vim: expandtab:tabstop=4:shiftwidth=4