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)