Original author: David Banas capn.freako@gmail.com

Original date: September 25, 2015

Copyright (c) 2015 David Banas; all rights reserved World wide.

This jupyter notebook contains my solutions to some of the exercises posed by Brent Yorgey, in his Typeclassopedia document.

- Phil Ruffwind rf@rufflewind.com
- Conal Elliott conal@conal.net

- Section 3.2 - Functor Instances
- Section 3.3 - Functor Laws
- Section 4.2 - Applicative Laws
- Section 4.3 - Applicative Instances
- Section 4.5 - Alternative Formulation (Monoidal)
- Section 10.2 - *Foldable* - Instances and Examples
- Section 10.3 - Derived Folds
- Ex. 10.3.1 - Implement *toList*.
- Ex. 10.3.2 - Implement *concat*, etc.
- Ex. 10.3.2.a - Implement *concat*.
- Ex. 10.3.2.b - Implement *concatMap*.
- Ex. 10.3.2.c - Implement *and*.
- Ex. 10.3.2.d - Implement *or*.
- Ex. 10.3.2.e - Implement *any*.
- Ex. 10.3.2.f - Implement *all*.
- Ex. 10.3.2.g - Implement *sum*.
- Ex. 10.3.2.h - Implement *product*.
- Ex. 10.3.2.i - Implement *maximum*.
- Ex. 10.3.2.j - Implement *minimum*.
- Ex. 10.3.2.k - Implement *elem*.
- Ex. 10.3.2.l - Implement *notElem*.
- Ex. 10.3.2.m - Implement *find*.

- Section 11.1 - Traversable Definition
- Section 11.2 - Traversable Intuiition
- Section 11.3 - Traversable Instances and Examples

```
In [1]:
```import Data.Time
putStrLn "Notebook last run:"
getCurrentTime

```
```

```
In [2]:
```class MyFunctor f where
fmap' :: (a -> b) -> f a -> f b
instance MyFunctor (Either e) where
fmap' g (Left e) = Left e
fmap' g (Right x) = Right (g x)
instance MyFunctor ((->) e) where
-- fmap' g f = g . f
fmap' = (.)
-- Testing Functor law on defined instances.
func_law x = fmap' id x == id x
func_law2 x = fmap' id f x == f x
where
f x = 2 * x
func_law (Left "Error String")
func_law (Right 1)
func_law2 (2::Int)

```
```

```
In [3]:
```instance MyFunctor ((,) e) where
fmap' g (e, a) = (e, g a)
data Pair a = Pair a a deriving (Eq, Show)
instance MyFunctor Pair where
fmap' g (Pair x y) = Pair (g x) (g y)
func_law ("msg", 0.1)
func_law $ Pair 1 2

```
```

**Discussion, as per exercise instructions:**

Similarities:

- Both types/instances return a pair of values.

Differences:

The type of the first member of the pair can differ from that of the second, in the '(,) e' case.

The mapped function, g, is only mapped over the second member of the pair, in the '(,) e' case.

The type of the second member of the pair is NOT included in the Functor instance, for either type, but the type of the first member IS included, for ((,) e), but NOT for Pair.

```
In [4]:
```data ITree a = Leaf (Int -> a)
| Node [ITree a]
instance Eq a => Eq (ITree a) where
Leaf g == Leaf h = g 0 == h 0
Node xs == Node ys = and (zipWith (==) xs ys)
Leaf _ == Node _ = False
Node _ == Leaf _ = False
instance MyFunctor ITree where
fmap' g (Leaf f) = Leaf (g . f)
fmap' g (Node its) = Node $ map (fmap' g) its
-- Test Functor identity law.
let f = Node [Leaf id, Leaf id] in
fmap' id f == f

```
```

```
In [5]:
```{-# LANGUAGE KindSignatures GADTs StandaloneDeriving DeriveFunctor #-}
data NoFunc :: * -> * where
NoFunc :: a -> NoFunc ()
deriving instance Functor (NoFunc)

```
```

```
In [6]:
```-- Yes: The following code compiles without error.
data Func1 a = Func1 a deriving (Functor)
data Func2 b = Func2 b deriving (Functor)
data CompFunc b = CompFunc (Func1 (Func2 b)) deriving (Functor)

I was pointed to the following solution, by Phil Ruffwind rf@rufflewind.com:

```
In [7]:
```data Break a = Yes | No deriving (Eq)
instance MyFunctor Break where
fmap' f _ = No
-- Test Functor id law.
fmap' id Yes == Yes
-- Test Functor composition law.
let g = id
h = const Yes
in fmap' (g . h) Yes == (fmap' g . fmap' h) Yes

```
```

```
In [8]:
```-- Evil Functor instance
instance MyFunctor [] where
fmap' _ [] = []
fmap' g (x:xs) = g x : g x : fmap g xs
-- Testing Functor identity law.
fmap' id [1,2,3] == [1,2,3]
-- Testing Functor composition law.
fmap' ((+ 1) . (* 2)) [1,2,3] == (fmap' (+ 1) . fmap' (* 2)) [1,2,3]

```
```

**To prove:**

`pure f <*> x = pure (flip ($)) <*> x <*> pure f`

**Available Laws/Properties:**

```
pure f <*> x = fmap f x = f <$> x (1st Applicative Law)
f <*> pure x = pure ($ x) <*> f = pure (flip ($) x) <*> f (interchange)
pure f <*> pure x = pure (f x) (homomorphism)
fmap h (fmap g f) = (fmap h . fmap g) f = fmap (h . g) f (2nd Functor Law)
```

**Useful Relationships:**

```
f = \x -> f x = ($) f = (f $) (function/lambda definition)
($ x) = \f -> f x = flip ($) x ("($ x)" syntax definition)`
```

**Proof:**

```
pure (flip ($)) <*> x <*> pure f = (associativity)
(pure (flip ($)) <*> x) <*> pure f = (interchange)
pure ($ f) <*> (pure (flip ($)) <*> x) = (1st Applicative Law)
fmap (flip ($) f) (fmap (flip ($)) x) = (g = flip ($))
fmap (g f) (fmap g x) = (Second Functor Law)
fmap (g f . g) x = (lemma 1, below)
fmap f x = (1st Applicative Law)
pure f <*> x
```

□

**Lemma 1:**

`(flip ($) g) . flip ($) == g`

**Types:**

```
g :: a -> b
flip ($) :: a1 -> ((a1 -> b1) -> b1)
flip ($) g :: ((a -> b) -> b1) -> b1
(flip ($) g) . flip ($) :: a -> b
```

**Proof:**

```
(flip ($) g) . flip ($) = (definition of "flip ($)")
((\x -> (\f -> f x)) g) . (\y -> (\f' -> f' y)) = (eta reduction)
(\f -> f g) . (\y -> (\f' -> f' y)) = (expansion of composition)
\y -> (\f' -> f' y) g = (eta reduction)
\y -> g y = (function/lambda definition)
g
```

□

```
In [9]:
```class MyApplicative f where
pure' :: a -> f a
(<@>) :: f (a -> b) -> f a -> f b
instance MyApplicative Maybe where
pure' = Just
Nothing <@> _ = Nothing
_ <@> Nothing = Nothing
Just g <@> Just a = Just (g a)

```
In [10]:
```-- Test the Applicative laws.
-- Identity
-- pure' id <@> Nothing == Nothing
pure' id <@> Nothing -- The above causes the IHaskell kernel to hang, while working fine in ghci.
-- Curiously, even though the error message, below, calls for this,
-- when I attempt to use it I get an error saying the function
-- 'isNothing' is not in scope! (?!)
-- isNothing (pure' id <@> Nothing)
Just id <@> Just 3 == Just 3
-- Homomorphism
Just (+ 2) <@> Just 3 == Just ((+ 2) 3)
-- Interchange
Just (+ 2) <@> Just 3 == Just ($ 3) <@> Just (+ 2)
-- Composition
Just (+ 2) <@> (Just (+ 3) <@> Just 4) == Just (.) <@> Just (+ 2) <@> Just (+ 3) <@> Just 4

```
```

```
In [11]:
```newtype ZipList a = ZipList { getZipList :: [a] } deriving (Eq)
instance MyApplicative ZipList where
pure' x = ZipList (repeat x)
(ZipList gs) <@> (ZipList xs) = ZipList (zipWith ($) gs xs)
-- Test the Applicative laws.
-- Identity
pure' id <@> ZipList ([1,2,3] :: [Int]) == ZipList [1,2,3]
-- Homomorphism
pure' (+ 2) <@> ZipList ([1,2,3] :: [Int]) == ZipList (map (+ 2) [1,2,3])
-- Interchange
ZipList (replicate 3 (+ 2)) <@> pure' 1 == pure' ($ 1) <@> ZipList (replicate 3 (+ 2))
-- Composition
ZipList (replicate 3 (+ 2)) <@> (ZipList (replicate 3 (+ 3)) <@> ZipList [1,2,3]) ==
pure' (.) <@> ZipList (replicate 3 (+ 2)) <@> ZipList (replicate 3 (+ 3)) <@> ZipList [1,2,3]

```
```

```
In [12]:
```class Applicative f => Monoidal f where
unit :: f ()
unit = pure ()
(**) :: f a -> f b -> f (a,b)
(**) fa fb = pure (,) <*> fa <*> fb

```
In [13]:
```class Monoidal f => MyApplicative f where
pure' :: a -> f a
pure' x = fmap (const x) unit
(<@>) :: f (a -> b) -> f a -> f b
fg <@> fx = fmap (uncurry ($)) (fg ** fx)

`fmap`

something over `unit`

and `(**)`

, in order to implement `pure`

and `<*>`

, suggests that the *Monoidal* implementation is more general (since we could `fmap`

something else, if that proved useful to some purpose).

```
In [14]:
```instance Monoidal Maybe
unit' :: Maybe () -> ()
unit' Nothing = ()
unit' (Just ()) = ()
unjoin :: Maybe (a, b) -> (Maybe a, Maybe b)
unjoin Nothing = (Nothing, Nothing)
unjoin (Just (x, y)) = (Just x, Just y)

**Laws:**

Left Identity:

`first (arr unit') $ unjoin Just ((), x) ≅ Just x`

Right Identity:

`second (arr unit') $ unjoin Just (x, ()) ≅ Just x`

Inverse:

`unit' . unit == ()`

**Proofs:**

Left Identity:

`first (arr unit') $ unjoin Just ((), x) = (definition of unjoin) first (arr unit') (Just (), Just x) = (application of "first (arr unit')") ((), Just x) ≅ (definition of isomorphism) Just x`

□

Right Identity:

(Trivial, as per Left Identity.)Inverse:

`unit' . unit = (definition of compose) unit' (unit) = (definition of unit) unit' (Just ()) = (definition of unit') ()`

□

**Applicative Laws:**

Identity:

`pure id <*> v = v`

Homomorphism:

`pure f <*> pure x = pure (f x)`

Interchange:

`u <*> pure y = pure ($ y) <*> u`

Composition:

`u <*> (v <*> w) = pure (.) <*> u <*> v <*> w`

**Monoidal Laws:**

Left Identity:

`unit ** v ≅ v`

Right Identity:

`u ** unit ≅ u`

Associativity:

`u ** (v ** w) ≅ (u ** v) ** w`

**Proofs:**

- Identity:

```
pure id <*> v = (implementation of (<*>), via (**))
fmap (uncurry ($)) (pure id ** v) = (implementation of pure, via unit)
fmap (uncurry ($)) ((fmap (const id) unit) ** v) = ()
fmap g (f x ** f y) = fmap g (f (x, y)) = f (g (x, y))
fmap (uncurry ($)) ((fmap (const id) unit) ** v) = (v = f x)
fmap (uncurry ($)) f (id, x) = f (id x) = f x = v
```

```
In [15]:
```import Data.Foldable
:t foldMap . foldMap
:t foldMap . foldMap . foldMap

```
```

They allow for the reduction of nested Foldable data structures:

```
In [16]:
```import Data.Monoid
ls = [[1,2,3], [4,5,6], [7,8,9]]
(foldMap . foldMap) Sum ls
(foldMap . foldMap) Product ls

```
```

```
In [17]:
```toList :: Foldable f => f a -> [a]
toList = foldMap (: [])
data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)
deriving (Show, Functor)
instance Foldable Tree where
foldMap f Empty = mempty
foldMap f (Leaf x) = f x
foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r
toList $ Node (Leaf 1) 2 (Leaf 3)

```
```

Pick some of the following functions to implement: concat, concatMap, and, or, any, all, sum, product, maximum(By), minimum(By), elem, notElem, and find. Figure out how they generalize to Foldable and come up with elegant implementations using fold or foldMap along with appropriate Monoid instances.

```
In [18]:
```concat :: [a] -> [a] -> [a]
-- concat [] ys = ys
-- concat (x:xs) ys = x : (concat xs ys)
-- concat xs ys = xs `mappend` ys
concat = mappend
concat [1,2,3] [4,5,6]

```
```

```
In [19]:
```concatMap :: (a -> [b]) -> [a] -> [b]
-- concatMap _ [] = []
-- concatMap g (x:xs) = g x ++ (concatMap g xs)
-- concatMap g xs = fold $ fmap g xs
-- concatMap g xs = (fold . fmap g) xs
-- concatMap g xs = foldMap g xs
concatMap = foldMap
concatMap (\x -> [x, x]) [1, 2, 3]

```
```

```
In [20]:
```and :: Foldable t => t Bool -> Bool
and = getAll . (foldMap All)
newtype All = All {getAll :: Bool}
instance Monoid All where
mempty = All True
mappend (All True) (All True) = All True
mappend _ _ = All False
and $ Node (Leaf True) True (Leaf True)
and $ Node (Leaf True) True (Leaf False)

```
```

```
In [21]:
```or :: Foldable t => t Bool -> Bool
or = getAny . (foldMap Any)
newtype Any = Any {getAny :: Bool}
instance Monoid Any where
mempty = Any False
mappend (Any False) (Any False) = Any False
mappend _ _ = Any True
or $ Node (Leaf False) False (Leaf True)
or $ Node (Leaf False) False (Leaf False)

```
```

```
In [22]:
```any :: Foldable t => t Bool -> Bool
any = or
any $ Node (Leaf False) False (Leaf True)
any $ Node (Leaf False) False (Leaf False)

```
```

```
In [23]:
```all :: Foldable t => t Bool -> Bool
all = and
all $ Node (Leaf True) True (Leaf True)
all $ Node (Leaf True) True (Leaf False)

```
```

```
In [24]:
```sum :: (Foldable t) => t Int -> Int
sum = getSum . (foldMap Sum)
newtype Sum = Sum {getSum :: Int}
instance Monoid Sum where
mempty = Sum 0
mappend (Sum x) (Sum y) = Sum (x + y)
sum $ Node (Leaf 1) 2 (Leaf 3)

```
```

```
In [25]:
```product :: (Foldable t) => t Int -> Int
product = getProd . (foldMap Prod)
newtype Prod = Prod {getProd :: Int}
instance Monoid Prod where
mempty = Prod 1
mappend (Prod x) (Prod y) = Prod (x * y)
product $ Node (Leaf 1) 2 (Leaf 3)

```
```

```
In [26]:
```maximum :: (Foldable t) => t Int -> Int
maximum = getMax . (foldMap Max)
newtype Max = Max {getMax :: Int}
instance Monoid Max where
mempty = Max 0
mappend (Max x) (Max y) | y > x = Max y
| otherwise = Max x
maximum $ Node (Leaf 1) 4 (Leaf 3)

```
```

```
In [27]:
```minimum :: (Foldable t) => t Int -> Int
minimum = getMin . (foldMap Min)
newtype Min = Min {getMin :: Int}
instance Monoid Min where
mempty = Min 1000000
mappend (Min x) (Min y) | y < x = Min y
| otherwise = Min x
minimum $ Node (Leaf 1) 4 (Leaf 3)

```
```

```
In [28]:
```elem :: (Foldable t, Eq a) => a -> t a -> Bool
elem x = getAny . (foldMap (Any . (== x)))
elem 4 $ Node (Leaf 1) 4 (Leaf 3)
elem 2 $ Node (Leaf 1) 4 (Leaf 3)

```
```

```
In [29]:
```notElem :: (Foldable t, Eq a) => a -> t a -> Bool
notElem x = not . (elem x)
notElem 4 $ Node (Leaf 1) 4 (Leaf 3)
notElem 2 $ Node (Leaf 1) 4 (Leaf 3)

```
```

```
In [30]:
```find :: Foldable t => (a -> Bool) -> t a -> Maybe a
find p = getFirst . foldMap (First . sel p)
where sel p x | p x = Just x
| otherwise = Nothing
t1 = Node (Leaf 1) 4 (Leaf 3)
find (> 2) t1
find (> 4) t1

```
```

```
In [31]:
```-- I don't seem to need the following line. I include it, here, because it was necessary,
-- when debugging the kernel hang mentioned, below, in GHCi.
import Prelude hiding (Traversable, sequenceA, traverse, mapM, sequence)
import Control.Applicative (WrappedMonad(..))
class (Functor t, Foldable t) => Traversable t where
traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
traverse g = sequenceA . fmap g
sequenceA :: Applicative f => t (f a) -> f (t a)
sequenceA = traverse id
mapM :: Monad m => (a -> m b) -> t a -> m (t b)
-- mapM g = unwrapMonad . sequenceA . (fmap (WrapMonad . g))
mapM g = unwrapMonad . traverse (WrapMonad . g)
sequence :: Monad m => t (m a) -> m (t a)
sequence = mapM id
-- If I remove the following two lines, the kernel hangs when I attempt to run the cell.
main :: IO ()
main = putStrLn "Hello, World!"

*There are at least two natural ways to turn a tree of lists into a list of trees. What are they, and why?*

They are:

- concatenation of all lists in the tree (going in the order prescribed by the tree's
*Foldable*instance), followed by mapping of the*Leaf*constructor, and - forming the list of all trees possible, by taking each value in the top node's list as the top node value in a new tree, and forming as many trees as are possible, via recursive application to both the left and right sub-trees, independently.

These two approaches are induced by the *Monoid* and *Applicative* instances for the inner functor (*List*), which are: *concatenation* and *outer product*, respectively.

By jumping ahead and copying the *Traversable* instance for *Tree* from the documentation, we can see this in code (because, the *sequenceA* function invokes the *Applicative* instance for the inner functor):

```
In [32]:
```instance Traversable Tree where
sequenceA Empty = pure Empty
sequenceA (Leaf f) = Leaf <$> f
sequenceA (Node t1 f t2) = Node <$> (sequenceA t1) <*> f <*> (sequenceA t2)
t = Node (Leaf [1]) [2, 3] (Leaf [4])
res = foldMap (fmap Leaf) t
res' = sequenceA t
print t
print res
print res'

```
```

```
In [33]:
```lofT2TofL :: [Tree a] -> Tree [a]
-- lofT2TofL [] = Empty
-- lofT2TofL (x:xs) = Node Empty (toList x) (lofT2TofL xs)
lofT2TofL = Leaf . concatMap toList
t1 = Empty
t2 = Leaf 1
t3 = Node (Leaf 2) 3 (Leaf 4)
l1 = [t1, t2, t3]
res = lofT2TofL l1
print l1
print res

```
```

```
In [34]:
```:t traverse
:t traverse . traverse

```
```

```
In [35]:
```-- (traverse . traverse) allows us to traverse nested Traversables:
toList2 :: Tree (Tree [a]) -> [Tree(Tree a)]
toList2 = (traverse . traverse) id
tt1 = Leaf (Leaf [1])
tt2 = Node (Leaf (Leaf [1,2])) (Leaf [3]) (Leaf (Leaf [4]))
tt3 = Node (Leaf (Leaf [1,2])) (Leaf [3]) (Leaf (Leaf []))
res1 = toList2 tt1
res2 = toList2 tt2
res3 = toList2 tt3
print res1
print res2
print res3

```
```

That last case is quite interesting; I don't completely understand it, yet.

```
In [36]:
```import Data.Functor.Identity (Identity (..))
-- fmap :: (a -> b) -> t a -> t b
-- fmap g xs = <some function of 'traverse'>
-- g :: a -> b
-- xs :: t a
--
-- traverse :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)
-- pure . g :: a -> f b
-- traverse (pure . g) xs :: f (t b)
-- runIdentity $ traverse (pure . g) xs :: t b (If f = Identity)
-- Want :: t b
-- fmap g xs = runIdentity $ traverse (pure . g) xs
fmap g = runIdentity . traverse (pure . g)
res = fmap (+ 1) t2
print t2
print res

```
```

```
In [37]:
```-- foldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m
-- foldMap g xs = <some function of 'traverse'>
-- g :: a -> m
-- xs :: t a
--
-- traverse :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)
-- AppMon . g :: a -> AppMon m b
-- traverse (AppMon . g) :: t a -> AppMon m (t b)
-- traverse (AppMon . g) xs :: AppMon m (t b)
-- getMon $ traverse (AppMon . g) xs :: m
-- ..
-- Want :: m
-- foldMap g xs = getMon $ traverse (AppMon . g) xs
foldMap g = getMon . traverse (AppMon . g)
-- Applicative wrapper around a Monoid.
newtype AppMon m a = AppMon {getMon :: m}
instance Functor (AppMon m) where
fmap _ (AppMon m) = (AppMon m)
instance (Monoid m) => Applicative (AppMon m) where
pure _ = AppMon mempty
x <*> y = AppMon $ getMon x `mappend` getMon y
res = getSum $ foldMap Sum t3
print t3
print res

```
```