Instantly share code, notes, and snippets.

Embed
What would you like to do?
Alternative Either <*> definition
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment