Complete Chapter 18

18-monad/18.7-chapter-exercises.md

@@ -0,0 +1,6 @@
+# Chapter Exercises
+## Writing and testing monad instances
+see src/instances.hs
+
+## Writing functions
+see src/functions.hs

18-monad/src/EitherMonad.hs

@@ -0,0 +1,54 @@
+module EitherMonad where
+
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+import Test.QuickCheck.Classes
+
+data Sum a b = First a | Second b deriving (Eq, Show)
+
+instance Functor (Sum a) where
+    fmap _ (First a) = First a
+    fmap f (Second  b) = Second (f b)
+
+instance Applicative (Sum a) where
+    pure = Second
+    (<*>) _ (First a) = First a
+    (<*>) (First a) _ = First a
+    (<*>) (Second f) (Second b) = Second (f b)
+
+instance Monad (Sum a) where
+    return = pure
+    (First a) >>= _  = First a
+    (Second b) >>= k = k b
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Sum a b) where
+    arbitrary = do
+        a <- arbitrary
+        b <- arbitrary
+        elements [First a, Second b]
+
+instance (Eq a, Eq b) => EqProp (Sum a b) where
+    (=-=) = eq
+
+type SumType = Sum String (Int,Int,Int)
+
+main :: IO ()
+main = do
+    quickBatch (monad (undefined :: SumType))
+
+-- ********************************
+-- Associativity
+-- (m >>= f) >>= g
+-- join (fmap g (join (fmap f m)))
+
+-- We can't just do
+-- m >>= (f >>= g) because f is not of type (Monoid m => m b)
+-- We want to pass an m to an h
+-- m >>= h 
+-- where h is to be determined, we know it is of form (Monoid m => a -> m b)
+-- and it should be based on f >>= g, this doesn't work, but we could apply
+-- f to an `a` and provide that to the:
+-- h x = f x >>= g
+-- This is can be done via anonymous function: 
+-- m >>= (\x -> f x >>= g)
+-- join (fmap (\x -> join (fmap g (f x))) m)

18-monad/src/bind.hs

@@ -0,0 +1,6 @@
+module Bind where
+
+import Control.Monad (join)
+
+bind :: Monad m => (a -> m b) -> m a -> m b
+bind = join . fmap f

18-monad/src/examples.hs

@@ -0,0 +1,124 @@
+module Examples where
+
+import Control.Monad (join)
+
+twiceWhenEven :: [Integer] -> [Integer]
+twiceWhenEven xs = do
+    x <- xs
+    if even x
+        then [x*x,x*x]
+        else [x*x]
+
+twiceWhenEven' :: [Integer] -> [Integer]
+twiceWhenEven' xs =
+    xs >>= \x -> if even x then [x*x,x*x] else [x*x]
+
+twiceWhenEven'' :: [Integer] -> [Integer]
+twiceWhenEven'' xs =
+     join (fmap (\x -> if even x then [x*x,x*x] else [x*x]) xs)
+
+
+data Cow = Cow { name :: String, age :: Int, weight :: Int }
+           deriving (Eq, Show)
+
+noEmpty :: String -> Maybe String
+noEmpty "" = Nothing
+noEmpty s = Just s
+
+noNegative :: Int -> Maybe Int
+noNegative n | n >= 0 = Just n
+             | otherwise = Nothing
+            
+weightCheck :: Cow -> Maybe Cow
+weightCheck c =
+    let w = weight c
+        n = name c
+    in if (n == "Bess") && (w > 499)
+       then Nothing
+       else Just c
+
+mkSphericalCow :: String -> Int -> Int -> Maybe Cow
+mkSphericalCow name' age' weight' =
+    case noEmpty name' of
+        Nothing -> Nothing
+        Just n ->
+            case noNegative age' of
+                Nothing -> Nothing
+                Just a ->
+                    case noNegative weight' of
+                        Nothing -> Nothing
+                        Just w -> weightCheck $ Cow n a w
+
+mkSphericalCow' :: String -> Int -> Int -> Maybe Cow
+mkSphericalCow' name' age' weight' = do
+    n <- noEmpty name'
+    a <- noNegative age'
+    w <- noNegative weight'
+    weightCheck $ Cow n a w
+
+mkSphericalCow'' :: String -> Int -> Int -> Maybe Cow
+mkSphericalCow'' name' age' weight' =
+    noEmpty name' >>= \n ->
+        noNegative age' >>= \a ->
+            noNegative weight'>>= \w ->
+                weightCheck $ Cow n a w
+
+mkSphericalCow''' :: String -> Int -> Int -> Maybe Cow
+mkSphericalCow''' name' age' weight' =
+    join (fmap f $ noEmpty name')
+    where f n = join (fmap g $ noNegative age')
+              where g a = join (fmap h $ noNegative weight')
+                        where h w = weightCheck $ Cow n a w 
+
+-- Some explanation:
+-- Starting at the end with the function h:
+-- h :: Int -> Maybe Cow
+
+-- We know g takes and Int (as the `a` given is used in the construction of
+-- Cow). `h` is fmapped over a Maybe Int, giving us a Maybe (Maybe Cow)
+-- (fmap :: (Int -> Maybe Cow) -> Maybe Int -> Maybe (Maybe Cow))
+-- Using join, reduces this to just a Maybe Cow, so this makes:
+-- g :: Int -> Maybe Cow
+
+-- And looking at f, we see that it takes a String (n is used as String).
+--  `g` is mapped over a Maybe Int, giving us a Maybe (Maybe Cow))
+-- (fmapp :: (Int -> Maybe Cow) -> Maybe Int -> Maybe (Maybe Cow))
+-- Using join reduces this to just a Maybe Cow to, so we have:
+-- f :: String -> Maybe Cow
+
+-- Finally `f` is mapped over a Maybe String, giving us a Maybe (Maybe Cow)
+-- (fmap :: (String -> Maybe Cow) -> Maybe String -> Maybe (Maybe Cow))
+-- Using join, reduces this to jsut a Maybe Cow, this gives us the
+-- Maybe Cow
+                        
+-- mkSphericalCow''' :: String -> Int -> Int -> Maybe Cow
+-- mkSphericalCow''' name' age' weight' = z name' age' weight'
+--     where z :: String -> Int -> Int -> Maybe Cow
+--           z n a w = join (fmap (f w a) $ noEmpty n)
+--           f :: Int -> Int -> String -> Maybe Cow
+--           f w a n = join (fmap (g w n) $ noNegative a)
+--           g :: Int -> String -> Int -> Maybe Cow
+--           g w n a = join (fmap (h n a) $ noNegative w)
+--           h :: String -> Int -> Int -> Maybe Cow
+--           h n a w = weightCheck $ Cow n a w
+
+f :: Integer -> Maybe Integer
+f 0 = Nothing
+f n = Just n
+
+g :: Integer -> Maybe Integer
+g i = if even i then (Just (i+1)) else Nothing
+
+h :: Integer -> Maybe String
+h i = Just ("10191" ++ show i)
+
+doSomething' :: Integer -> Maybe (Integer, Integer, String)
+doSomething' n = do
+    a <- f n
+    b <- g a
+    c <- h b
+    pure (a, b, c)
+
+doSomething'' :: Integer -> Maybe (Integer, Integer, String)
+doSomething'' n =
+    (pure g) <*> (f n)

18-monad/src/functions.hs

@@ -0,0 +1,58 @@
+module Functions where
+
+-- 1
+j :: Monad m => m (m a) -> m a
+j x = x >>= id
+
+-- 2
+l1 :: Monad m => (a -> b) -> m a -> m b
+-- without fmap
+l1 f x = do
+    a' <- x
+    return $ f a'
+l1 f x = x >>= (return . f)
+-- with fmap :)
+-- l1 = fmap
+
+-- 3
+l2 :: Monad m => (a -> b -> c) -> m a -> m b -> m c
+-- without fmap
+l2 f x y = do
+    a' <- x
+    b  <- y
+    return $ f a' b 
+-- l2 f x y = x >>= (\a -> y >>= \b -> return $ f a b)
+-- with fmap
+-- l2 f x y = (fmap f x) <*> y
+
+-- 4
+a :: Monad m => m a -> m (a -> b) -> m b
+-- without fmap
+a x fs = do
+    a' <- x
+    f  <- fs
+    return $ f a'
+-- with fmap
+-- a x fs = do
+--     f <- fs
+--     fmap f x
+-- a x fs = fs >>= \y -> fmap y x
+-- a x fs = fs <*> x
+
+-- 5
+meh :: Monad m => [a] -> (a -> m b) -> m [b]
+meh [] _ = return []
+meh (x:xs) f = do
+    b <- f x
+    fmap (b:) $ meh xs f
+-- using flipType as base
+-- meh as f = flipType (fmap f as)
+
+-- 6
+flipType :: (Monad m) => [m a] -> m [a]
+flipType = flip meh id
+-- and without using meh
+-- flipType [] = return []
+-- flipType (x:xs) = do
+--     x' <- x
+--     fmap (x':) $ flipType xs

18-monad/src/instances.hs

@@ -0,0 +1,160 @@
+module Instances where
+
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+import Test.QuickCheck.Classes
+
+-- import Control.Monad (join)
+import Control.Applicative (liftA2)
+
+-- 1
+data Nope a = NopeDotJpg deriving (Eq, Show)
+instance Functor Nope where
+    fmap _ _ = NopeDotJpg
+instance Applicative Nope where
+    pure _ = NopeDotJpg
+    (<*>) _ _ = NopeDotJpg
+instance Monad Nope where
+    return _ = NopeDotJpg
+    (>>=) _ _ = NopeDotJpg
+instance Arbitrary (Nope a) where
+    arbitrary = return NopeDotJpg
+instance EqProp (Nope a) where
+    (=-=) = eq
+type NopeType = Nope (Int,Int,Int)
+
+-- 2
+data PhhhbbtttEither b a = Left' a | Right' b deriving (Eq, Show)
+instance Functor (PhhhbbtttEither b) where
+    fmap _ (Right' b) = Right' b
+    fmap f (Left' a)  = Left' (f a)
+instance Monoid b => Applicative (PhhhbbtttEither b) where
+    pure = Left'
+    (Right' b) <*> (Right' b') = Right' $ b `mappend` b'
+    (Right' b) <*> _ = Right' b
+    _ <*> (Right' b) = Right' b
+    (Left' f) <*> (Left' a) = Left' (f a)
+instance Monoid b => Monad (PhhhbbtttEither b) where
+    return = Left'
+    (Right' b) >>= _ = Right' b
+    (Left' a) >>= k  = k a
+instance (Arbitrary a, Arbitrary b) => Arbitrary (PhhhbbtttEither b a) where
+    arbitrary = do
+        a <- arbitrary
+        b <- arbitrary
+        oneof [return $ Left' a, return $ Right' b]
+instance (Eq a, Eq b) => EqProp (PhhhbbtttEither b a) where
+    (=-=) = eq
+type PhhhbbtttEitherType = PhhhbbtttEither String (Int,Int,Int)
+
+-- 3
+newtype Identity a = Identity a deriving (Eq, Ord, Show)
+instance Functor Identity where
+    fmap f (Identity a) = Identity $ f a
+instance Applicative Identity where
+    pure = Identity
+    (Identity f) <*> (Identity a) = Identity $ f a
+instance Monad Identity where
+    return = Identity
+    (Identity a) >>= k = k a
+instance Arbitrary a => Arbitrary (Identity a) where
+    arbitrary = arbitrary >>= return . Identity
+instance Eq a => EqProp (Identity a) where
+    (=-=) = eq
+type IdentityType = Identity (Int,Int,Int)
+
+-- 4
+data List a = Nil | Cons a (List a) deriving (Eq, Show)
+instance Functor List where
+    fmap _ Nil = Nil
+    fmap f (Cons a l) = Cons (f a) (fmap f l)
+instance Monoid (List a) where
+    mempty = Nil
+    mappend l Nil = l
+    mappend Nil l = l
+    mappend (Cons a l) l' = Cons a (mappend l l')
+instance Applicative List where
+    {-# INLINE pure #-}
+    pure = flip Cons Nil
+    {-# INLINE (<*>) #-}
+    Nil <*> _ = Nil
+    _ <*> Nil = Nil
+    (Cons f fl) <*> as = (fmap f as) `mappend` (fl <*> as)
+instance Monad List where
+    return = flip Cons Nil
+    Nil >>= _ = Nil
+    (Cons a l) >>= k = (k a) `mappend` (l >>= k)
+
+    -- I originally had the above, because I thought that you could not
+    -- use join, but I found a solution online that uses join. Trying to
+    -- understand: 
+    -- join is defined as (join x = x >>= id)
+    -- You might think, wait a minute? id is (a -> a) and thus doesn't fit the
+    -- bill of (a -> m b), but let's look at things more closely
+    --
+    -- (>>=) :: m a -> (a -> m b) -> m b
+    -- a here is the type of x :: (m a')
+    -- b here is the inner type of x :: a', 
+    -- updating gives us:
+    -- (>>=) :: m (m a') -> (m a' -> m a') -> m a'
+    -- and we see that we can pass the id function to it
+
+    -- This turns the >>= definition into a recursive one where the second time
+    -- the function is the id, which will join it all
+    
+    -- unfortunately this crashes when testing the monad laws ... Why?
+    -- because this never ends... You get
+    -- fmap id (fmap id (... (fmap id (fmap f as))))
+    -- as >>= f = join $ fmap f as
+    
+-- toList :: [a] -> List a
+-- toList [] = Nil
+-- toList (x:xs) = Cons x $ toList xs
+
+replicateM' :: Applicative m => Int -> m a -> m (List a)
+replicateM' cnt0 f = loop cnt0
+    where loop cnt
+                | cnt <= 0 = pure Nil
+                | otherwise = liftA2 Cons f (loop (cnt - 1))
+  
+listOf' :: Gen a -> Gen (List a)
+listOf' gen = sized $ \n ->
+    do k <- choose (0,n)
+       replicateM' k gen
+
+
+instance Arbitrary a => Arbitrary (List a) where
+    arbitrary = listOf' arbitrary
+    -- arbitrary = fmap toList (listOf arbitrary)
+    -- arbitrary = do
+    --     a <- arbitrary
+    --     l <- arbitrary
+    --     frequency [(1, return Nil), (3, return $ Cons a l)]
+instance Eq a => EqProp (List a) where
+    (=-=) = eq
+type ListType = List (Int,Int,Int)
+
+main :: IO ()
+main = do
+    quickBatch (functor  (undefined :: NopeType))
+    quickBatch (applicative (undefined :: NopeType))
+    quickBatch (monad (undefined :: NopeType))
+
+    quickBatch (functor (undefined :: PhhhbbtttEitherType))
+    quickBatch (applicative (undefined :: PhhhbbtttEitherType))
+    quickBatch (monad (undefined :: PhhhbbtttEitherType))
+
+    quickBatch (functor (undefined :: IdentityType))
+    quickBatch (applicative (undefined :: IdentityType))
+    quickBatch (monad (undefined :: IdentityType))
+
+    -- [a]
+    quickBatch (functor (undefined :: [(Int,Int,Int)]))
+    quickBatch (monoid (undefined :: [(Int,Int,Int)]))
+    quickBatch (applicative (undefined :: [(Int,Int,Int)]))
+    quickBatch (monad (undefined :: [(Int,Int,Int)]))
+
+    quickBatch (functor (undefined :: ListType))
+    quickBatch (monoid (undefined :: ListType))
+    quickBatch (applicative (undefined :: ListType))
+    quickBatch (monad (undefined :: ListType))