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