diff options
author | William Carroll <wpcarro@gmail.com> | 2020-06-18T10·07+0100 |
---|---|---|
committer | William Carroll <wpcarro@gmail.com> | 2020-06-18T10·07+0100 |
commit | a981bb0d4a6e0e4d7aadc4a650e2f700c992d2cf (patch) | |
tree | 15e5e32a24ec17923ebd0abba279b66997dd1201 /scratch | |
parent | 71e79f5f5d7514f8739927ea4cde7271febe5b07 (diff) |
Complete the Monad chapter
From "Haskell Programming from First Principles"... I have completed all of the exercises in the book thus far, but I only recently dedicated a Haskell module for each chapter. Previously I created ad hoc modules per exercise, per chapter... it was chaotic.
Diffstat (limited to 'scratch')
-rw-r--r-- | scratch/haskell-programming-from-first-principles/monad.hs | 178 |
1 files changed, 178 insertions, 0 deletions
diff --git a/scratch/haskell-programming-from-first-principles/monad.hs b/scratch/haskell-programming-from-first-principles/monad.hs new file mode 100644 index 000000000000..2f80b457b125 --- /dev/null +++ b/scratch/haskell-programming-from-first-principles/monad.hs @@ -0,0 +1,178 @@ +module MonadScratch where + +import Data.Function ((&)) +import Test.QuickCheck +import Test.QuickCheck.Checkers +import Control.Applicative (liftA2) +import qualified Control.Monad as Monad + +-------------------------------------------------------------------------------- + +bind :: Monad m => (a -> m b) -> m a -> m b +bind f x = Monad.join $ fmap f x + +-------------------------------------------------------------------------------- + +fTrigger :: Functor f => f (Int, String, [Int]) +fTrigger = undefined + +aTrigger :: Applicative a => a (Int, String, [Int]) +aTrigger = undefined + +mTrigger :: Monad m => m (Int, String, [Int]) +mTrigger = undefined + +-------------------------------------------------------------------------------- + +data Sum a b + = Fst a + | Snd b + deriving (Eq, Show) + +instance (Eq a, Eq b) => EqProp (Sum a b) where + (=-=) = eq + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Sum a b) where + arbitrary = frequency [ (1, Fst <$> arbitrary) + , (1, Snd <$> arbitrary) + ] + +instance Functor (Sum a) where + fmap f (Fst x) = Fst x + fmap f (Snd x) = Snd (f x) + +instance Applicative (Sum a) where + pure x = Snd x + (Snd f) <*> (Snd x) = Snd (f x) + (Snd f) <*> (Fst x) = Fst x + (Fst x) <*> _ = Fst x + +instance Monad (Sum a) where + (Fst x) >>= _ = Fst x + (Snd x) >>= f = f x + +-------------------------------------------------------------------------------- + +data Nope a = NopeDotJpg deriving (Eq, Show) + +instance Arbitrary (Nope a) where + arbitrary = pure NopeDotJpg + +instance EqProp (Nope a) where + (=-=) = eq + +instance Functor Nope where + fmap f _ = NopeDotJpg + +instance Applicative Nope where + pure _ = NopeDotJpg + _ <*> _ = NopeDotJpg + +instance Monad Nope where + NopeDotJpg >>= f = NopeDotJpg + +-------------------------------------------------------------------------------- + +data BahEither b a + = PLeft a + | PRight b + deriving (Eq, Show) + +instance (Arbitrary b, Arbitrary a) => Arbitrary (BahEither b a) where + arbitrary = frequency [ (1, PLeft <$> arbitrary) + , (1, PRight <$> arbitrary) + ] + +instance (Eq a, Eq b) => EqProp (BahEither a b) where + (=-=) = eq + +instance Functor (BahEither b) where + fmap f (PLeft x) = PLeft (f x) + fmap _ (PRight x) = PRight x + +instance Applicative (BahEither b) where + pure = PLeft + (PRight x) <*> _ = PRight x + (PLeft f) <*> (PLeft x) = PLeft (f x) + _ <*> (PRight x) = PRight x + +instance Monad (BahEither b) where + (PRight x) >>= _ = PRight x + (PLeft x) >>= f = f x + +-------------------------------------------------------------------------------- + +newtype Identity a = Identity a + deriving (Eq, Ord, Show) + +instance Functor Identity where + fmap f (Identity x) = Identity (f x) + +instance Applicative Identity where + pure = Identity + (Identity f) <*> (Identity x) = Identity (f x) + +instance Monad Identity where + (Identity x) >>= f = f x + +-------------------------------------------------------------------------------- + +data List a + = Nil + | Cons a (List a) + deriving (Eq, Show) + +instance Arbitrary a => Arbitrary (List a) where + arbitrary = frequency [ (1, pure Nil) + , (1, Cons <$> arbitrary <*> arbitrary) + ] + +instance Eq a => EqProp (List a) where + (=-=) = eq + +fromList :: [a] -> List a +fromList [] = Nil +fromList (x:xs) = Cons x (fromList xs) + +instance Semigroup (List a) where + Nil <> xs = xs + xs <> Nil = xs + (Cons x xs) <> ys = + Cons x (xs <> ys) + +instance Functor List where + fmap f Nil = Nil + fmap f (Cons x xs) = Cons (f x) (fmap f xs) + +instance Applicative List where + pure x = Cons x Nil + Nil <*> _ = Nil + _ <*> Nil = Nil + (Cons f fs) <*> xs = + (f <$> xs) <> (fs <*> xs) + +instance Monad List where + Nil >>= _ = Nil + (Cons x xs) >>= f = (f x) <> (xs >>= f) + +-------------------------------------------------------------------------------- + +j :: Monad m => m (m a) -> m a +j = Monad.join + +l1 :: Monad m => (a -> b) -> m a -> m b +l1 = Monad.liftM + +l2 :: Monad m => (a -> b -> c) -> m a -> m b -> m c +l2 = Monad.liftM2 + +a :: Monad m => m a -> m (a -> b) -> m b +a = flip (<*>) + +meh :: Monad m => [a] -> (a -> m b) -> m [b] +meh xs f = flipType $ f <$> xs + +flipType :: Monad m => [m a] -> m [a] +flipType [] = pure mempty +flipType (m:ms) = + m >>= (\x -> (x:) <$> flipType ms) |