diff --git a/25-composing-types/25.4-twinplicative.md b/25-composing-types/25.4-twinplicative.md new file mode 100644 index 0000000..590c251 --- /dev/null +++ b/25-composing-types/25.4-twinplicative.md @@ -0,0 +1,2 @@ +# GOTCHA! Exercise time +see src/gotcha.hs \ No newline at end of file diff --git a/25-composing-types/25.6-compose-instances.md b/25-composing-types/25.6-compose-instances.md new file mode 100644 index 0000000..4d709d8 --- /dev/null +++ b/25-composing-types/25.6-compose-instances.md @@ -0,0 +1,5 @@ +# Exercises: Compose Instances +see src/gotcha.hs + +## Bifunctor +see src/bifunctor.hs \ No newline at end of file diff --git a/25-composing-types/src/IdendityT.hs b/25-composing-types/src/IdendityT.hs new file mode 100644 index 0000000..8f906cc --- /dev/null +++ b/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) diff --git a/25-composing-types/src/bifunctor.hs b/25-composing-types/src/bifunctor.hs new file mode 100644 index 0000000..ed9dbc2 --- /dev/null +++ b/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) + + + + + + diff --git a/25-composing-types/src/gotcha.hs b/25-composing-types/src/gotcha.hs new file mode 100644 index 0000000..017c35f --- /dev/null +++ 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) + + +