Complete chapter 25

25-composing-types/25.4-twinplicative.md

@@ -0,0 +1,2 @@
+# GOTCHA! Exercise time
+see src/gotcha.hs

25-composing-types/25.6-compose-instances.md

@@ -0,0 +1,5 @@
+# Exercises: Compose Instances
+see src/gotcha.hs
+
+## Bifunctor
+see src/bifunctor.hs

25-composing-types/src/IdendityT.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE InstanceSigs #-}
+module IdentityT where
+
+newtype IdentityT f a = IdentityT { runIdentityT :: f a }
+
+instance Functor f => Functor (IdentityT f) where
+    fmap f (IdentityT fa) = IdentityT $ fmap f fa
+
+instance Applicative f => Applicative (IdentityT f) where
+    pure a = IdentityT $ pure a
+
+    (IdentityT ff) <*> (IdentityT fa) =
+        IdentityT $ ff <*> fa
+
+instance Monad m => Monad (IdentityT m) where
+    return = pure
+
+    (>>=) :: IdentityT m a -> (a -> IdentityT m b) -> IdentityT m b
+    (IdentityT ma) >>= f =
+        IdentityT $ ma >>= (runIdentityT . f)

25-composing-types/src/bifunctor.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE InstanceSigs #-}
+module BiFunctor where
+
+import Data.Bifunctor
+
+data Deux a b = Deux a b
+instance Bifunctor Deux where
+    bimap :: (a -> b) -> (c -> d) -> Deux a c -> Deux b d
+    bimap f g (Deux a b) = Deux (f a) (g b)
+
+data Const a b = Const a
+instance Bifunctor Const where
+    bimap f _ (Const a) = Const (f a)
+
+data Drei a b c = Drei a b c
+instance Bifunctor (Drei a) where
+    bimap f g (Drei a b c) = Drei a (f b) (g c)
+
+data SuperDrei a b c = SuperDrei a b
+instance Bifunctor (SuperDrei a) where
+    bimap f _ (SuperDrei a b) = SuperDrei a (f b)
+
+data SemiDrei a b c = SemiDrei a
+instance Bifunctor (SemiDrei a) where
+    bimap _ _ (SemiDrei a) = SemiDrei a
+
+data Quadriceps a b c d = Quadzzz a b c d
+instance Bifunctor (Quadriceps a b) where
+    bimap f g (Quadzzz a b c d) = Quadzzz a b (f c) (g d)
+
+data Either' a b = Left' a | Right' b
+instance Bifunctor Either' where
+    bimap f _ (Left' a) = Left' (f a)
+    bimap _ g (Right' b) = Right' (g b)
+
+
+
+
+
+

25-composing-types/src/gotcha.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE InstanceSigs #-}
+module Gotcha where
+
+newtype Identity a = Identity { runIdentity :: a }
+
+instance Functor Identity where
+    fmap f (Identity a) = Identity $ f a
+
+instance Applicative Identity where
+    pure = Identity
+    (Identity f) <*> (Identity a) = Identity (f a)
+
+--
+newtype Compose f g a = Compose { getCompose :: f (g a) } deriving (Eq, Show)
+
+instance (Functor f, Functor g) => Functor (Compose f g) where
+    fmap f (Compose fga) = Compose $ (fmap . fmap) f fga
+
+instance (Applicative f, Applicative g) => Applicative (Compose f g) where
+    pure :: a -> Compose f g a
+    pure a = Compose $ pure (pure a)
+    -- The next one took me a while. I find the following usefull in
+    -- understanding the solution. Ignoring the Compose part of it we
+    -- have a type signature of:
+    -- :: f (g (a -> b)) -> f (g a) -> f (g b)
+    -- In the applicative the following would be easy:
+    -- :: f (g a -> g b) -> f (g a) -> f (g b)
+    -- as that would just (<*>), if we somehow find a way to go from
+    -- :: f (g (a -> b)) to (f (g a -> g b)) using applicative and/or functor
+    -- functions we would be set.
+    -- If you ignore the f part of it,  you see we have:
+    -- :: g (a -> b) -> g a -> g b which is nothing but (<*>)
+    -- We can also see this as:
+    -- :: g (a -> b) -> (g a -> g b)
+    -- In other words this is a function that returns another function where
+    -- we know that the first argument/function is embeded in an f. We can use
+    -- the fact that f is a functor to actually apply the function:
+    -- :: fmap (g (a -> b) -> (g a -> g b)) (f (g (a -> b))) :: f (g a -> g b)
+    -- Which brings us to:
+    -- :: (<*>) f a = (fmap (<*>) f) <*> a
+    (<*>) :: Compose f g (a -> b) -> Compose f g a -> Compose f g b
+    (Compose h) <*> (Compose c) = Compose $ 
+        (fmap (<*>) h) <*> c
+
+instance (Foldable f, Foldable g) => Foldable (Compose f g) where
+    foldMap :: (Monoid m) => (a -> m) -> Compose f g a -> m
+    foldMap f (Compose fga) = (foldMap . foldMap) f fga
+
+-- foldMap :: (Monoid m, Foldable t) => (a -> m) -> (t a -> m)
+-- (.) :: (b -> c) -> (a -> b) -> a -> c
+-- Foldmap for f :: (g a -> m) -> f (g a) -> m
+-- FoldMap for g :: (a -> m) -> g a -> m
+-- (foldMap . foldMap) :: (a -> m) -> f (g a) -> m
+
+instance (Traversable f, Traversable g) => Traversable (Compose f g) where
+    traverse :: Applicative f' => (a -> f' b) -> Compose f g a 
+                                            -> f' (Compose f g b)
+    traverse f (Compose fga) = Compose <$> ((traverse . traverse) f fga)
+
+-- traverse :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)
+-- traverse for f :: ((g a) -> f' (g b)) -> f (g a) -> f' (f (g b))
+-- traverse for g :: (a -> f' b) -> g a -> f' (g b)
+-- (traverse . traverse) :: (a -> f' b) -> f (g a) -> f' (f g b)
+
+
+