diff --git a/tests/Main.hs b/tests/Main.hs index d1f9388..ae204a5 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -18,38 +18,35 @@ main = defaultMain tests tests :: [Test] tests = - [ - testGroup "Kleisli Category" $ testCategory (>=>) return + [ testGroup "Kleisli Category" $ testCategory (>=>) return , testGroup "Respond Category" $ testCategory (/>/) respond - ++ [ - testProperty "Distributivity" prop_respond_Distributivity - ] + ++ [ testProperty "Distributivity" prop_respond_Distributivity + ] , testGroup "Request Category" $ testCategory (\>\) request - ++ [ - testProperty "Distributivity" prop_request_Distributivity - , testProperty "Zero Law" prop_request_ZeroLaw - ] + ++ [ 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 - ] + , 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 @@ -164,7 +161,6 @@ instance Arbitrary AProxy where 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 @@ -177,40 +173,39 @@ aProxy = foldr (>=>) return . map f . unAProxy type ProxyK = Int -> Proxy Int Int Int Int (Writer [Int]) Int type Operation = ProxyK -> ProxyK -> ProxyK -infix 0 >==< +infix 0 === -(>==<) :: ProxyK -> ProxyK -> AServer -> AClient -> Bool -(>==<) pl pr p0 p1 = +(===) :: 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 + :: Operation + -> ProxyK -- right/left identity element + -> AProxy -> AServer -> AClient -> Bool gen_prop_RightIdentity (>>>) idt f' = let f = aProxy f' - in (f >>> idt) >==< f + in (f >>> idt) === f gen_prop_LeftIdentity (>>>) idt f' = let f = aProxy f' - in (idt >>> f) >==< f + in (idt >>> f) === f gen_prop_Associativity - :: Operation - -> AProxy -> AProxy -> AProxy -> AServer -> AClient -> Bool + :: 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 + in f >>> (g >>> h) === (f >>> g) >>> h testCategory :: Operation -> ProxyK -> [Test] testCategory op idt = - [ - testProperty "Left Identity" $ gen_prop_LeftIdentity op idt + [ testProperty "Left Identity" $ gen_prop_LeftIdentity op idt , testProperty "Right Identity" $ gen_prop_RightIdentity op idt , testProperty "Associativity" $ gen_prop_Associativity op ] @@ -221,7 +216,7 @@ prop_respond_Distributivity f' g' h' = let f = aProxy f' g = aProxy g' h = aProxy h' - in (f >=> g) />/ h >==< (f />/ h) >=> (g />/ h) + in (f >=> g) />/ h === (f />/ h) >=> (g />/ h) -- Request Category @@ -229,11 +224,11 @@ prop_request_Distributivity f' g' h' = let f = aProxy f' g = aProxy g' h = aProxy h' - in f \>\ (g >=> h) >==< (f \>\ g) >=> (f \>\ h) + in f \>\ (g >=> h) === (f \>\ g) >=> (f \>\ h) prop_request_ZeroLaw f' = let f = aProxy f' - in (f \>\ return) >==< return + in (f \>\ return) === return -- Push/Pull @@ -241,37 +236,37 @@ prop_pushPull_Associativity f' g' h' = let f = aProxy f' g = aProxy g' h = aProxy h' - in (f >+> g) >~> h >==< f >+> (g >~> 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 + in reflect . (f \>\ g) === reflect . g />/ reflect . f -prop_dual_RequestIdentity = reflect . request >==< respond +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 + in reflect . (f />/ g) === reflect . g \>\ reflect . f -prop_dual_RespondIdentity = reflect . respond >==< request +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 + in reflect . (f >=> g) === reflect . f >=> reflect . g -prop_dual_ReflectZeroLaw = reflect . return >==< return +prop_dual_ReflectZeroLaw = reflect . return === return prop_dual_Involution f' = let f = aProxy f' - in (reflect . reflect) . f >=> return >==< f + in (reflect . reflect) . f >=> return === f -- Functor Laws prop_FunctorIdentity p' = let p = aProxy p' - in fmap id p >==< id p + in fmap id p === id p