Complete Chapter 17

17-applicative/17.5-lookups.md

@@ -0,0 +1,2 @@
+# Exercises: Lookups
+see src/lookups.hs

17-applicative/17.8.md

@@ -0,0 +1,8 @@
+# List Applicative Exercise
+see src/List.hs
+
+# ZipList Applicative Exercise
+see src/List.hs
+
+# Exercuse: Variation on Either
+see src/Validation.hs

17-applicative/17.9-chapter-excercises.md

@@ -0,0 +1,12 @@
+# Chapter Excercises
+## fill in the types
+1. `pure :: a -> [a]`, `(<*>) :: [(a -> b)] -> [a] -> [b]`
+2. `pure :: a -> IO a`,  `(<*>) :: IO (a -> b) -> IO a -> IO b`
+3. `pure :: a -> (b,a)`, `(<*>) :: (c, (a -> b)) -> (c, a) -> (c, b)`
+4. `pure :: a -> (e -> a)`, `(<*>) :: (e -> (a -> b))) -> (e -> a) -> (e -> b)`
+
+## Write instances
+see src/instances.hs
+
+## Combinations
+see src/combinations.hs 

17-applicative/src/BadMonoid.hs

@@ -0,0 +1,22 @@
+module BadMonoid where
+
+import Data.Monoid
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+import Test.QuickCheck.Classes
+
+data Bull = Fools | Twoo deriving (Eq, Show)
+
+instance Arbitrary Bull where
+    arbitrary =
+        frequency [ (1, return Fools), (1, return Twoo)]
+
+instance Monoid Bull where
+    mempty = Fools
+    mappend _ _ = Fools
+
+instance EqProp Bull where 
+    (=-=) = eq
+
+main :: IO ()
+main = quickBatch (monoid Twoo)

17-applicative/src/Constant.hs

@@ -0,0 +1,11 @@
+module Constant where
+
+newtype Constant a b = Constant { getConstant :: a }
+    deriving (Eq, Ord, Show)
+
+instance Functor (Constant a) where
+    fmap _ (Constant a) = (Constant a)
+
+instance Monoid a => Applicative (Constant a) where
+     pure _ = Constant mempty
+     (<*>) (Constant a) (Constant a') = Constant (mappend a a')

17-applicative/src/Identity.hs

@@ -0,0 +1,11 @@
+module Identity where
+
+newtype Identity a = Identity a deriving (Show, Eq, Ord)
+
+instance Functor Identity where
+    fmap f (Identity a) = Identity (f a)
+
+instance Applicative Identity where
+    pure = Identity
+    (<*>) (Identity f) = fmap f
+

17-applicative/src/List.hs

@@ -0,0 +1,159 @@
+module List where 
+
+import Data.Functor ((<$>))
+import Data.Monoid ((<>))
+
+import Test.QuickCheck.Gen (sized)
+import Control.Applicative (liftA2)
+
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+import Test.QuickCheck.Classes
+
+data List a = Nil | Cons a (List a) deriving (Eq, Show)
+
+-- My original implementation (before looking at the list)
+-- instance Applicative List where
+--     pure a = Cons a Nil
+--     _ <*> Nil = Nil -- strictly not neccessary but slightly faster?
+--                     -- if the List is empty then the last pattern mach
+--                     -- will be 
+--                     -- (<>) ((<$>) f Nil) (fl <*> Nil)
+--                     -- (<>) Nil ((<>) ((<$>) f Nil) (fl' <> Nil))
+--                     -- Which will continue until fl/fl' is Nil and which
+--                     -- will pattern match with second pattern match
+
+--     Nil <*> _ = Nil
+--     (Cons f fl) <*> l = 
+--         (<>) ((<$>) f l) (fl <*> l)
+
+
+instance Functor List where
+    fmap _ Nil = Nil
+    fmap f (Cons a l) = Cons (f a) (f <$> l)
+
+instance Monoid (List a) where
+    mempty = Nil
+    mappend Nil l = l
+    mappend l Nil = l
+    mappend (Cons a al) l = Cons a $ al  <> l
+
+-- The append function from the book is just (<>)
+-- from the Monoid typeclass
+-- append :: List a -> List a -> List a
+-- append Nil ys = ys
+-- append (Cons x xs) ys = Cons x $ xs `append` ys
+
+-- We probably could also implemnt the Foldable typeclass, so
+-- we can start using foldr, but this _is_ foldr :)
+fold :: (a -> b -> b) -> b -> List a -> b
+fold _ b Nil = b
+fold f b (Cons h t) = f h (fold f b t)
+
+concat' :: List (List a) -> List a
+concat' = fold (<>) Nil
+
+flatMap :: (a -> List b) -> List a -> List b
+flatMap f = (concat' . (<$>) f)
+
+
+-- Imagine we have a List of functions `fs` and a List of elements `as`
+-- For each f in fs we want to fmap it over al and append the result.
+-- We can use the now defined flatMap for this, but we should figure
+-- out what is what. (a -> List b) -> List a -> List b
+
+-- Option 1
+-- If `List a` is the `as` then (a -> List b) should be a function
+-- that takes an `a` and has all functions applied to it
+-- This would be akin to: fmap ($a) fs 
+
+-- instance Applicative List where
+--     pure = flip Cons Nil
+--     fs <*> xs = flatMap (\x -> ($x) <$> fs) xs
+
+-- But this doesn't look so nice. We could look at it slightly different
+-- Option 2
+-- If `List a` is the `fs` then (a -> List b) should be a function that
+-- takes an `f` and applies it to all `as`.
+-- This would be fmap f as or \f -> fmap f xs or (`fmap` xs) 
+instance Applicative List where
+    pure = flip Cons Nil
+    fs <*> xs = flatMap (<$> xs) fs
+
+-- First attempt at Arbitrary for List
+-- Slow for the composition test
+fromList :: List a -> [a]
+fromList Nil = []
+fromList (Cons a l) = a : fromList l
+
+toList :: [a] -> List a
+toList [] = Nil
+toList (x:xs) = Cons x (toList xs)
+
+instance Arbitrary a => Arbitrary (List a) where
+    arbitrary = do
+        as <- listOf arbitrary
+        return $ toList as
+
+-- Have to find a good balance for Nil
+-- instance Arbitrary a => Arbitrary (List a) where
+--     arbitrary = do
+--         a <- arbitrary
+--         l <- arbitrary
+--         frequency [(9,return $ Cons a l), (1, return Nil)]
+
+-- Peaking at arbitrary for [], also long which made my first
+-- version actually pretty ok! The difference is probably in the
+-- size of lists generated between this and the other frequency one
+
+-- 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))
+
+-- vectorOf' :: Int -> Gen a -> Gen (List a)
+-- vectorOf' = replicateM'
+
+-- listOf' :: Gen a -> Gen (List a)
+-- listOf' gen = sized $ \n ->
+--     do k <- choose (0,n)
+--        vectorOf' k gen
+
+
+-- instance Arbitrary a => Arbitrary (List a) where
+--     arbitrary = listOf' arbitrary
+
+instance Eq a => EqProp (List a) where
+    (=-=) = eq
+
+-- take' :: Int -> List a -> List a
+-- take' = undefined
+
+-- newtype ZipList' a = ZipList' (List a) deriving (Eq, Show)
+
+-- instance Eq a => EqProp (ZipList' a) where
+--     xs =-= ys = xs' `eq` ys'
+--       where xs' = let (ZipList' l) = xs
+--                   in take' 3000 l
+--             ys' = let (ZipList' l) = ys
+--                   in take' 3000 l
+
+-- instance Functor ZipList' where
+--     (<$>) f (ZipList' xs) = ZipList' $ (<$>) f xs
+
+-- instance Applicative ZipList' where
+--     pure a = ZipList' (Cons a Nil)
+--     (ZipList' Nil) <*> _ = ZipList' Nil
+--     _ <*> (ZipList' Nil) = ZipList' Nil
+--     (ZipList' (Cons f fl)) <*> (ZipList' (Cons a as)) =
+--         ZipList' $ Cons (f a) (recurse fl as)
+--         where recurse fl' as' =
+--                 let (ZipList' z) = ((ZipList' fl') <*> (ZipList' as'))
+--                 in z
+
+main :: IO ()
+main = do
+    quickBatch (monoid (Nil :: List Int))
+    quickBatch (applicative (Nil :: List (Int,Int,Int)))

17-applicative/src/Person.hs

@@ -0,0 +1,28 @@
+module Person where
+
+validateLength :: Int -> String -> Maybe String
+validateLength maxLen s =
+    if (length s) > maxLen
+    then Nothing
+    else Just s
+
+newtype Name = Name String deriving (Eq, Show)
+newtype Address = Address String deriving (Eq, Show)
+
+mkName :: String -> Maybe Name
+mkName s = fmap Name $ validateLength 25 s
+
+mkAddress :: String -> Maybe Address
+mkAddress a = fmap Address $ validateLength 100 a
+
+data Person = Person Name Address deriving (Eq, Show)
+
+mkPerson :: String -> String -> Maybe Person
+-- mkPerson n a = 
+--     case mkName n of
+--         Nothing -> Nothing
+--         Just n' ->
+--             case mkAddress a of
+--                 Nothing -> Nothing
+--                 Just a' -> Just $ Person n' a'
+mkPerson n a = Person <$> mkName n <*> mkAddress a

17-applicative/src/Validation.hs

@@ -0,0 +1,36 @@
+module Validation' where
+
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+import Test.QuickCheck.Classes
+
+data Validation' e a = Failure' e | Success' a deriving (Eq, Show)
+
+instance Functor (Validation' e) where
+    fmap _ (Failure' e) = Failure' e
+    fmap f (Success' s) = Success' $ f s
+
+instance Monoid e => Applicative (Validation' e) where
+    pure = Success'
+    (Failure' e) <*> (Failure' e') = Failure' $ e `mappend` e'
+    (Failure' e) <*> _ = Failure' e
+    _ <*> (Failure' e) = Failure' e
+    (Success' f) <*> s = fmap f s
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Validation' a b) where
+    arbitrary = do
+        a <- arbitrary
+        b <- arbitrary
+        elements [Failure' a, Success' b]
+
+instance (Eq a, Eq b) => EqProp (Validation' a b) where
+    (=-=) (Failure' _) (Success' _) = property False
+    (=-=) (Success' _) (Failure' _) = property False
+    (=-=) a b = eq a b
+
+test :: Validation' String (Int, Int, Int)
+test = undefined
+
+main :: IO ()
+main = do
+    quickBatch (applicative test)

17-applicative/src/combinations.hs

@@ -0,0 +1,12 @@
+module Combinations where
+
+import Control.Applicative (liftA3)
+
+stops :: String 
+stops = "pbtdkg"
+
+vowels :: String
+vowels = "aeiou"
+
+combos :: [a] -> [b] -> [c] -> [(a,b,c)]
+combos = liftA3 (,,)

17-applicative/src/instances.hs

@@ -0,0 +1,129 @@
+module Instances where
+
+import Data.Monoid (Sum, Product)
+
+import Test.QuickCheck
+import Test.QuickCheck.Checkers
+import Test.QuickCheck.Classes
+
+-- 1
+data Pair a = Pair a a deriving (Show, Eq)
+instance Functor Pair where
+    fmap f (Pair a a') = Pair (f a) (f a')
+instance Applicative Pair where
+    pure x = Pair x x
+    (<*>) (Pair f f') (Pair a a') = Pair (f a) (f' a')
+instance Arbitrary a => Arbitrary (Pair a) where
+    arbitrary = do
+        a <- arbitrary
+        a' <- arbitrary
+        return $ Pair a a'
+instance Eq a => EqProp (Pair a) where
+    (=-=) = eq
+type PairType = Pair (Int, Int, Int)
+
+-- 2
+data Two a b = Two a b deriving (Show, Eq)
+instance Functor (Two a) where
+    fmap f (Two a b) = Two a (f b)
+instance Monoid a => Applicative (Two a)  where
+    pure = Two mempty
+    (<*>) (Two a f) (Two a' b) = Two (mappend a a') (f b)
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where
+    arbitrary = do
+        a <- arbitrary
+        b <- arbitrary
+        return $ Two a b
+instance (Eq a, Eq b) => EqProp (Two a b) where
+    (=-=) = eq
+type TwoType = Two String (Int,Int,Int)
+
+-- 3
+data Three a b c = Three a b c deriving (Show, Eq)
+instance Functor (Three a b) where
+    fmap f (Three a b c) = Three a b (f c)
+instance (Monoid a, Monoid b) => Applicative (Three a b) where
+    pure x = Three mempty mempty x
+    (<*>) (Three a b f) (Three a' b' c) = Three (mappend a a')
+                                                (mappend b b')
+                                                (f c)
+instance (Arbitrary a, Arbitrary b, Arbitrary c) 
+    => Arbitrary (Three a b c) where 
+        arbitrary = do
+            a <- arbitrary
+            b <- arbitrary
+            c <- arbitrary
+            return $ Three a b c
+instance (Eq a, Eq b, Eq c) => EqProp (Three a b c) where
+    (=-=) = eq    
+type ThreeType = Three String (Sum Int) (Int, Int, Int)
+
+-- 4
+data Three' a b  = Three' a b b deriving (Show, Eq)
+instance Functor (Three' a) where
+    fmap f (Three' a b b') = Three' a (f b) (f b')
+instance Monoid a => Applicative (Three' a) where
+    pure x = Three' mempty x x
+    (<*>) (Three' a f f') (Three' a' b b') = Three' (mappend a a')
+                                                    (f b) (f' b')
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Three' a b) where
+    arbitrary = do
+        a <- arbitrary
+        b <- arbitrary
+        b' <- arbitrary
+        return $ Three' a b b'
+instance (Eq a, Eq b) => EqProp (Three' a b) where
+    (=-=) = eq
+type Three'Type = Three' String (Int,Int,Int)
+
+-- 5
+data Four a b c d = Four a b c d deriving (Show, Eq)
+instance Functor (Four a b c) where
+    fmap f (Four a b c d) = Four a b c (f d)
+instance (Monoid a, Monoid b, Monoid c) => Applicative (Four a b c) where
+    pure = Four mempty mempty mempty 
+    (<*>) (Four a b c f) (Four a' b' c' d) = Four (mappend a a')
+                                                  (mappend b b')
+                                                  (mappend c c')
+                                                  (f d)
+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
+    => Arbitrary (Four a b c d) where
+        arbitrary = do
+            a <- arbitrary
+            b <- arbitrary
+            c <- arbitrary
+            d <- arbitrary
+            return $ Four a b c d
+instance (Eq a, Eq b, Eq c, Eq d) => EqProp (Four a b c d) where
+    (=-=) = eq
+type FourType = Four String (Sum Int) Ordering (Int, Int, Int)
+
+-- 6
+data Four' a b = Four' a a a b deriving (Show, Eq)
+instance Functor (Four' a) where
+    fmap f (Four' a a' a'' b) = Four' a a' a'' (f b)
+instance (Monoid a) => Applicative (Four' a) where
+    pure = Four' mempty mempty mempty
+    (<*>) (Four' a b c f) (Four' a' b' c' d) = Four' (mappend a a')
+                                                     (mappend b b')
+                                                     (mappend c c')
+                                                     (f d)
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Four' a b) where
+    arbitrary = do
+        a <- arbitrary
+        a' <- arbitrary
+        a'' <- arbitrary
+        b <- arbitrary
+        return $ Four' a a' a'' b
+instance (Eq a, Eq b) => EqProp (Four' a b) where
+    (=-=) = eq
+type Four'Type = Four' String (Int,Int,Int)
+
+main :: IO ()
+main = do
+    quickBatch (applicative (undefined :: PairType))
+    quickBatch (applicative (undefined :: TwoType))
+    quickBatch (applicative (undefined :: ThreeType ))
+    quickBatch (applicative (undefined :: Three'Type))
+    quickBatch (applicative (undefined :: FourType))
+    quickBatch (applicative (undefined :: Four'Type))

17-applicative/src/lookups.hs

@@ -0,0 +1,43 @@
+module Lookups where
+
+import Data.List (elemIndex)
+
+xs :: [Integer]
+xs = [1,2,3]
+ys :: [Integer]
+ys = [4,5,6]
+
+added :: Maybe Integer
+added = (+3) <$> (lookup 3 $ zip xs ys)
+
+y :: Maybe Integer
+y = lookup 3 $ zip xs ys
+
+z :: Maybe Integer
+z = lookup 2 $ zip xs ys
+
+tupled :: Maybe (Integer, Integer)
+tupled = (,) <$> y <*> z
+
+-- 3
+x' :: Maybe Int
+x' = elemIndex 3 ([1,2,3,4,5] :: [Integer])
+
+y' :: Maybe Int
+y' = elemIndex 4 ([1,2,3,4,5] :: [Integer])
+
+max' :: Int -> Int -> Int
+max' = max
+
+maxed :: Maybe Int
+maxed = max' <$> x' <*> y'
+
+-- 4
+x'' :: Maybe Integer
+x'' = lookup 3 $ zip xs ys
+
+y'' :: Maybe Integer
+y'' = lookup 2 $ zip xs ys
+
+summed :: Maybe Integer
+summed = pure sum <*> ((,) <$> x'' <*> y'')