module Main where
import Data.Monoid
import Test.QuickCheck
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes
import Control.Applicative (liftA, liftA2)
import Control.Monad (join)
-- Exercise: Either Monad
data Sum' a b
= First' a
| Second' b
deriving (Eq, Show)
instance (Semigroup a, Semigroup b) => Semigroup (Sum' a b) where
(<>) (First' x1) (First' x2) = First' (x1 <> x2)
(<>) (Second' x1) (Second' x2) = Second' (x1 <> x2)
(<>) (First' x) _ = First' x
(<>) _ (First' x) = First' x
instance (Monoid a, Monoid b) => Monoid (Sum' a b) where
mempty = First' mempty
mappend = (<>)
instance Functor (Sum' a) where
fmap f (First' x) = First' x
fmap f (Second' x) = Second' (f x)
instance (Semigroup a) => Applicative (Sum' a) where
pure = Second'
(<*>) (First' x1) (First' x2) = First' (x1 <> x2)
(<*>) (First' x1) (Second' _) = First' x1
(<*>) (Second' _) (First' x1) = First' x1
(<*>) (Second' f) (Second' x) = Second' (f x)
instance (Semigroup a) => Monad (Sum' a) where
return = pure
(>>=) (First' x) _ = First' x
(>>=) m_a f = join $ fmap f m_a
-- Chapter Exercises
-- 1.
data Nope a =
NopeDotJpg
deriving (Eq, Show)
instance Semigroup (Nope a) where
(<>) _ _ = NopeDotJpg
instance Monoid (Nope a) where
mempty = NopeDotJpg
mappend = (<>)
instance Functor Nope where
fmap _ _ = NopeDotJpg
instance Applicative Nope where
pure _ = NopeDotJpg
(<*>) _ _ = NopeDotJpg
instance Monad Nope where
return = pure
_ >>= _ = NopeDotJpg
instance Arbitrary (Nope a) where
arbitrary = return NopeDotJpg
instance (Eq a) => EqProp (Nope a) where
(=-=) = eq
testTypeNope :: Nope (String, String, String)
testTypeNope = undefined
labelSection :: String -> IO ()
labelSection x = putStrLn ("\nTesting " ++ x ++ "\n-----------------\n")
nopeMonad = do
labelSection "Nope a"
quickBatch $ functor testTypeNope
quickBatch $ applicative testTypeNope
quickBatch $ monad testTypeNope
--2.
data PhhbbtttEither b a
= Left' a
| Right' b
deriving (Eq, Show)
instance (Semigroup a, Semigroup b) => Semigroup (PhhbbtttEither b a) where
(<>) (Left' x1) (Left' x2) = Left' (x1 <> x2)
(<>) (Left' _) (Right' x) = Right' x
(<>) (Right' x) (Left' _) = Right' x
(<>) (Right' x1) (Right' x2) = Right' (x1 <> x2)
instance (Monoid a, Monoid b) => Monoid (PhhbbtttEither b a) where
mempty = Left' mempty
mappend = (<>)
instance Functor (PhhbbtttEither b) where
fmap f (Right' x) = Right' x
fmap f (Left' x) = Left' (f x)
instance (Semigroup b) => Applicative (PhhbbtttEither b) where
pure = Left'
(<*>) (Left' f) (Left' x) = Left' (f x)
(<*>) (Right' x1) (Right' x2) = Right' (x1 <> x2)
(<*>) (Left' f) (Right' x) = Right' x
(<*>) (Right' x) (Left' y) = Right' x
instance (Arbitrary a, Arbitrary b) => Arbitrary (PhhbbtttEither b a) where
arbitrary = do
x <- arbitrary
y <- arbitrary
frequency [(1, return (Right' x)), (8, return (Left' y))]
instance (Semigroup b) => Monad (PhhbbtttEither b) where
return = pure
Right' x >>= _ = Right' x
Left' x >>= f = f x
-- Why does this type check but that hang whe you try to execute it??
-- m_a >>= f = join $ fmap f m_a
getInt :: String -> PhhbbtttEither String Int
getInt x =
case x of
"0" -> Left' 0
"1" -> Left' 1
"2" -> Left' 2
"3" -> Left' 3
"4" -> Left' 4
"5" -> Left' 5
"6" -> Left' 6
"7" -> Left' 7
"8" -> Left' 8
"9" -> Left' 9001
x -> Right' (x ++ " is not a digit 0-9")
eitherOver9000 :: Int -> PhhbbtttEither String Int
eitherOver9000 x
| x > 9000 = Left' x
| otherwise = Right' ("not over 9000, meh: " ++ show x)
instance (Eq b, Eq a) => EqProp (PhhbbtttEither b a) where
(=-=) = eq
testTypePhhbbtttEither ::
PhhbbtttEither (String, Product Int, String) (String, Product Int, String)
testTypePhhbbtttEither = undefined
phhbbtttEitherMonad = do
labelSection "PhhbbtttEither b a"
putStrLn "Sanity test"
print $ getInt "3" >>= eitherOver9000
quickBatch $ functor testTypePhhbbtttEither
quickBatch $ applicative testTypePhhbbtttEither
quickBatch $ monad testTypePhhbbtttEither
-- 3.
newtype Identity a =
Identity a
deriving (Eq, Ord, Show)
instance Functor Identity where
fmap f (Identity x) = Identity (f x)
instance Applicative Identity where
pure = Identity
(<*>) (Identity f) (Identity x) = Identity (f x)
instance Monad Identity where
return = pure
Identity x >>= f = f x
instance (Arbitrary a) => Arbitrary (Identity a) where
arbitrary = fmap Identity arbitrary
instance (Eq a) => EqProp (Identity a) where
(=-=) = eq
testTypeIdentity :: Identity (String, Product Int, String)
testTypeIdentity = undefined
identityMonad = do
labelSection "Identity a"
quickBatch $ functor testTypeIdentity
quickBatch $ applicative testTypeIdentity
quickBatch $ monad testTypeIdentity
-- 4.
data List a
= Nil
| Cons a (List a)
deriving (Eq, Show)
instance Functor List where
fmap f Nil = Nil
fmap f (Cons x xs) = Cons (f x) (fmap f xs)
concatList :: List a -> List a -> List a
concatList Nil Nil = Nil
concatList Nil xs = xs
concatList xs Nil = xs
concatList (Cons x Nil) ys = Cons x ys
concatList (Cons x xs) ys = Cons x (concatList xs ys)
instance Applicative List where
pure f = Cons f Nil
Nil <*> _ = Nil
_ <*> Nil = Nil
Cons f fs <*> xs =
let cL = concatList
in fmap f xs `cL` (fs <*> xs)
gimmeThree :: a -> List a
gimmeThree x = Cons x (Cons x (Cons x Nil))
instance Monad List where
return = pure
Nil >>= _ = Nil
Cons x xs >>= f =
let cL = concatList
in f x `cL` (xs >>= f)
-- Why does this type check?
-- xs >>= f = join (fmap f xs)
instance (Arbitrary a) => Arbitrary (List a) where
arbitrary =
frequency [(1, return Nil), (6, (return Cons) <*> arbitrary <*> arbitrary)]
instance (Eq a) => EqProp (List a) where
(=-=) = eq
testTypeList :: List (String, Product Int, String)
testTypeList = undefined
listMonad = do
labelSection "List a"
putStrLn "Sanity test"
let bob = Cons 1 (Cons 2 (Cons 3 Nil)) >>= gimmeThree
print bob
quickBatch $ functor testTypeList
quickBatch $ applicative testTypeList
quickBatch $ monad testTypeList
main :: IO ()
main = do
nopeMonad
phhbbtttEitherMonad
identityMonad
listMonad
-- Implement methods of Monad and Functor
-- 1.
j :: Monad m => m (m a) -> m a
j = join
-- 2.
l1 :: Monad m => (a -> b) -> m a -> m b
l1 = fmap
-- 3.
l2 :: Monad m => (a -> b -> c) -> m a -> m b -> m c
l2 = liftA2
-- 4.
a :: Monad m => m a -> m (a -> b) -> m b
a = flip (<*>)
-- 5.
meh :: Monad m => [a] -> (a -> m b) -> m [b]
meh [] f = return []
meh (x:xs) f = (return (:)) <*> (f x) <*> (meh xs f)
-- 6.
flipType :: Monad m => [m a] -> m [a]
flipType xs = meh xs id