Alternative Either <*> definition

either.hs

module Test where

import Control.Applicative

data EitherX a b = LeftX a | RightX b deriving (Eq, Show)

instance Functor (EitherX a) where
    fmap f (RightX x) = RightX $ f x
    fmap _ (LeftX e) = LeftX e

instance Applicative (EitherX a) where
    pure = RightX

    RightX f <*> v = f <$> v
    LeftX e <*> RightX _ = LeftX e
    LeftX _ <*> LeftX e = LeftX e


{-
identity
    pure id <*> v = v
-}
checkIdentity :: IO ()
checkIdentity = do

    let v1 = RightX "value" :: EitherX String String
        v2 = LeftX "failed"  :: EitherX String String

    print $ (pure id <*> v1) == v1
    print $ (pure id <*> v2) == v2

{-
composition
    pure (.) <*> u <*> v <*> w = u <*> (v <*> w)
-}
checkComposition :: IO ()
checkComposition = do
    let u1 = RightX (take 1) :: EitherX String (String -> String)
        v1 = LeftX "failed1" :: EitherX String (String -> String)
        w1 = LeftX "failed2" :: EitherX String String

        u2 = LeftX "failed3" :: EitherX String (String -> String)
        v2 = LeftX "failed4" :: EitherX String (String -> String)
        w2 = RightX "value" :: EitherX String String

    print $ (pure (.) <*> u1 <*> v1 <*> w1) == (u1 <*> (v1 <*> w1))
    print $ (pure (.) <*> u2 <*> v2 <*> w2) == (u2 <*> (v2 <*> w2))

{-
homomorphism
    pure f <*> pure x = pure (f x)
-}
checkHomomorphism :: IO ()
checkHomomorphism = do
    -- not important all values will be `RightX`
    return ()

{-
interchange
    u <*> pure y = pure ($ y) <*> u
-}
checkInterchange :: IO ()
checkInterchange = do
    let u1 = RightX (take 1) :: EitherX String (String -> String)
    let u2 = LeftX "failed" :: EitherX String (String -> String)
        y = "value"

    print $ (u1 <*> pure y) == (pure ($ y) <*> u1)
    print $ (u2 <*> pure y) == (pure ($ y) <*> u2)

main :: IO ()
main = do
    checkIdentity
    checkComposition
    checkHomomorphism
    checkInterchange