pipes-4.1.1: tests/Main.hs

module Main (main) where

import Data.Function                        (on)
import Data.List                            (intercalate)
import Control.Monad                        ((>=>))
import Control.Monad.Trans.Writer           (Writer, runWriter, tell)
import Test.QuickCheck                      (Gen, Arbitrary(..), choose)
import Test.Framework                       (defaultMain, testGroup, Test)
import Test.Framework.Providers.QuickCheck2 (testProperty)

import Pipes
import Pipes.Core
import Prelude hiding (log)


main :: IO ()
main = defaultMain tests

tests :: [Test]
tests =
    [ testGroup "Kleisli Category"        $ testCategory (>=>) return
    , testGroup "Respond Category"        $ testCategory (/>/) respond
     ++ [ testProperty "Distributivity" prop_respond_Distributivity
        ]
    , testGroup "Request Category"        $ testCategory (\>\) request
     ++ [ testProperty "Distributivity" prop_request_Distributivity
        , testProperty "Zero Law"       prop_request_ZeroLaw
        ]
    , testGroup "Pull Category"           $ testCategory (>+>) pull
    , testGroup "Push Category"           $ testCategory (>~>) push
    , testGroup "Push/Pull"
        [ testProperty "Associativity"  prop_pushPull_Associativity
        ]
    , testGroup "Duals"
        [ testGroup "Request"
            [ testProperty "Composition" prop_dual_RequestComposition
            , testProperty "Identity"    prop_dual_RequestIdentity
            ]
        , testGroup "Respond"
            [ testProperty "Composition" prop_dual_RespondComposition
            , testProperty "Identity"    prop_dual_RespondIdentity
            ]
        , testProperty "Distributivity"  prop_dual_ReflectDistributivity
        , testProperty "Zero Law"        prop_dual_ReflectZeroLaw
        , testProperty "Involution"      prop_dual_Involution
        ]
    , testGroup "Functor Laws"
        [ testProperty "Identity"        prop_FunctorIdentity
        ]
    ]

arbitraryBoundedEnum' :: (Bounded a, Enum a) => Gen a
arbitraryBoundedEnum' =
  do let mn = minBound
         mx = maxBound `asTypeOf` mn
     n <- choose (fromEnum mn, fromEnum mx)
     return (toEnum n `asTypeOf` mn)

data ClientStep
    = ClientRequest
    | ClientLog
    | ClientInc
      deriving (Enum, Bounded)

instance Arbitrary ClientStep where
    arbitrary = arbitraryBoundedEnum'
    shrink _  = []

instance Show ClientStep where
    show x = case x of
        ClientRequest -> "request"
        ClientLog     -> "log"
        ClientInc     -> "inc"

data ServerStep
    = ServerRespond
    | ServerLog
    | ServerInc
      deriving (Enum, Bounded)

instance Arbitrary ServerStep where
    arbitrary = arbitraryBoundedEnum'
    shrink _  = []

instance Show ServerStep where
    show x = case x of
        ServerRespond -> "respond"
        ServerLog     -> "log"
        ServerInc     -> "inc"

data ProxyStep
    = ProxyRequest
    | ProxyRespond
    | ProxyLog
    | ProxyInc deriving (Enum, Bounded)

instance Arbitrary ProxyStep where
    arbitrary = arbitraryBoundedEnum'
    shrink _  = []

instance Show ProxyStep where
    show x = case x of
        ProxyRequest -> "request"
        ProxyRespond -> "respond"
        ProxyLog     -> "log"
        ProxyInc     -> "inc"

log :: Int -> Proxy a' a b' b (Writer [Int]) Int
log n = do
    lift (tell [n])
    return n

inc :: (Monad m) => Int -> Proxy a' a b' b m Int
inc n = return (n + 1)

correct :: String -> String
correct str = case str of
    [] -> "return"
    _  -> str

newtype AClient = AClient { unAClient :: [ClientStep] }

instance Arbitrary AClient where
    arbitrary = fmap AClient arbitrary
    shrink    = map AClient . shrink . unAClient

instance Show AClient where
    show = correct . intercalate " >=> " . map show . unAClient

aClient :: AClient -> Int -> Client Int Int (Writer [Int]) Int
aClient = foldr (>=>) return . map f . unAClient
  where
    f x = case x of
        ClientRequest -> request
        ClientLog     -> log
        ClientInc     -> inc

newtype AServer = AServer { unAServer :: [ServerStep] }

instance Arbitrary AServer where
    arbitrary = fmap AServer arbitrary
    shrink    = map AServer . shrink . unAServer

instance Show AServer where
    show = correct . intercalate " >=> " . map show . unAServer

aServer :: AServer -> Int -> Server Int Int (Writer [Int]) Int
aServer = foldr (>=>) return . map f . unAServer
  where
    f x = case x of
        ServerRespond -> respond
        ServerLog     -> log
        ServerInc     -> inc

newtype AProxy = AProxy { unAProxy :: [ProxyStep] }

instance Arbitrary AProxy where
    arbitrary = fmap AProxy arbitrary
    shrink    = map AProxy . shrink . unAProxy

instance Show AProxy where
    show = correct . intercalate " >=> " . map show . unAProxy

aProxy :: AProxy -> Int -> Proxy Int Int Int Int (Writer [Int]) Int
aProxy = foldr (>=>) return . map f . unAProxy
  where
    f x = case x of
        ProxyRequest -> request
        ProxyRespond -> respond
        ProxyLog     -> log
        ProxyInc     -> inc

type ProxyK    = Int -> Proxy Int Int Int Int (Writer [Int]) Int
type Operation = ProxyK -> ProxyK -> ProxyK

infix 0 ===

(===) :: ProxyK -> ProxyK -> AServer -> AClient -> Bool
(===) pl pr p0 p1 =
  let sv  = aServer p0
      cl  = aClient p1
      f p = runWriter (runEffect (p 0))
  in on (==) f (sv >+> pl >+> cl) (sv >+> pr >+> cl)

gen_prop_RightIdentity, gen_prop_LeftIdentity
    :: Operation
    -> ProxyK -- right/left identity element
    -> AProxy -> AServer -> AClient -> Bool
gen_prop_RightIdentity (>>>) idt f' =
    let f = aProxy  f'
    in (f >>> idt) === f

gen_prop_LeftIdentity (>>>) idt f' =
    let f = aProxy f'
    in (idt >>> f) === f

gen_prop_Associativity
    :: Operation
    -> AProxy -> AProxy -> AProxy -> AServer -> AClient -> Bool
gen_prop_Associativity (>>>) f' g' h' =
    let f = aProxy  f'
        g = aProxy  g'
        h = aProxy  h'
    in f >>> (g >>> h) === (f >>> g) >>> h

testCategory :: Operation -> ProxyK -> [Test]
testCategory op idt =
    [ testProperty "Left Identity"  $ gen_prop_LeftIdentity  op idt
    , testProperty "Right Identity" $ gen_prop_RightIdentity op idt
    , testProperty "Associativity"  $ gen_prop_Associativity op
    ]

-- Respond Category

prop_respond_Distributivity f' g' h' =
    let f = aProxy  f'
        g = aProxy  g'
        h = aProxy  h'
    in (f >=> g) />/ h === (f />/ h) >=> (g />/ h)

-- Request Category

prop_request_Distributivity f' g' h' =
    let f = aProxy  f'
        g = aProxy  g'
        h = aProxy  h'
    in f \>\ (g >=> h) === (f \>\ g) >=> (f \>\ h)

prop_request_ZeroLaw f' =
    let f = aProxy  f'
    in (f \>\ return) === return

-- Push/Pull

prop_pushPull_Associativity f' g' h' =
    let f = aProxy f'
        g = aProxy g'
        h = aProxy h'
    in (f >+> g) >~> h === f >+> (g >~> h)

-- Duals

prop_dual_RequestComposition f' g' =
    let f = aProxy f'
        g = aProxy g'
    in reflect . (f \>\ g) === reflect . g />/ reflect . f

prop_dual_RequestIdentity = reflect . request === respond

prop_dual_RespondComposition f' g' =
    let f = aProxy f'
        g = aProxy g'
    in  reflect . (f />/ g) === reflect . g \>\ reflect . f

prop_dual_RespondIdentity = reflect . respond === request

prop_dual_ReflectDistributivity f' g' =
    let f = aProxy f'
        g = aProxy g'
    in reflect . (f >=> g) === reflect . f >=> reflect . g

prop_dual_ReflectZeroLaw = reflect . return === return

prop_dual_Involution f' =
    let f = aProxy f'
    in (reflect . reflect) . f >=> return === f

-- Functor Laws

prop_FunctorIdentity p' =
    let p = aProxy p'
    in fmap id p === id p