diff --git a/17-applicative/17.5-lookups.md b/17-applicative/17.5-lookups.md new file mode 100644 index 0000000..788dae1 --- /dev/null +++ b/17-applicative/17.5-lookups.md @@ -0,0 +1,2 @@ +# Exercises: Lookups +see src/lookups.hs \ No newline at end of file diff --git a/17-applicative/17.8.md b/17-applicative/17.8.md new file mode 100644 index 0000000..118b365 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/17-applicative/17.9-chapter-excercises.md b/17-applicative/17.9-chapter-excercises.md new file mode 100644 index 0000000..d7d766f --- /dev/null +++ b/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 \ No newline at end of file diff --git a/17-applicative/src/BadMonoid.hs b/17-applicative/src/BadMonoid.hs new file mode 100644 index 0000000..3823f90 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/17-applicative/src/Constant.hs b/17-applicative/src/Constant.hs new file mode 100644 index 0000000..f71ecc2 --- /dev/null +++ b/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') diff --git a/17-applicative/src/Identity.hs b/17-applicative/src/Identity.hs new file mode 100644 index 0000000..b44d395 --- /dev/null +++ b/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 + diff --git a/17-applicative/src/List.hs b/17-applicative/src/List.hs new file mode 100644 index 0000000..87b831d --- /dev/null +++ b/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))) \ No newline at end of file diff --git a/17-applicative/src/Person.hs b/17-applicative/src/Person.hs new file mode 100644 index 0000000..e953b1b --- /dev/null +++ b/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 \ No newline at end of file diff --git a/17-applicative/src/Validation.hs b/17-applicative/src/Validation.hs new file mode 100644 index 0000000..f90edb1 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/17-applicative/src/combinations.hs b/17-applicative/src/combinations.hs new file mode 100644 index 0000000..dda390b --- /dev/null +++ b/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 (,,) \ No newline at end of file diff --git a/17-applicative/src/instances.hs b/17-applicative/src/instances.hs new file mode 100644 index 0000000..d7a1f77 --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/17-applicative/src/lookups.hs b/17-applicative/src/lookups.hs new file mode 100644 index 0000000..4c4c691 --- /dev/null +++ b/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'') \ No newline at end of file