1 files changed, 79 insertions, 0 deletions
diff --git a/scratch/haskell-programming-from-first-principles/monad-transformers.hs b/scratch/haskell-programming-from-first-principles/monad-transformers.hs
new file mode 100644
index 000000000000..508fc018f380
--- /dev/null
+++ b/scratch/haskell-programming-from-first-principles/monad-transformers.hs
@@ -0,0 +1,79 @@
+module MonadTransformersScratch where
+
+import Data.Function ((&))
+--------------------------------------------------------------------------------
+
+newtype MaybeT m a =
+  MaybeT { runMaybeT :: m (Maybe a) }
+
+instance (Functor f) => Functor (MaybeT f) where
+  fmap f (MaybeT run) =
+    MaybeT $ (fmap . fmap) f run
+
+instance (Applicative m) => Applicative (MaybeT m) where
+  pure x = x & pure & pure & MaybeT
+  _ <*> _ = undefined
+
+instance (Monad m) => Monad (MaybeT m) where
+  return = pure
+  (MaybeT ma) >>= f = MaybeT $ do
+    maybeX <- ma
+    case maybeX of
+      Nothing -> pure Nothing
+      Just x -> x & f & runMaybeT
+
+--------------------------------------------------------------------------------
+
+newtype EitherT e m a =
+  EitherT { runEitherT :: m (Either e a) }
+
+instance (Functor m) => Functor (EitherT e m) where
+  fmap f (EitherT mEither) =
+    EitherT $ (fmap . fmap) f mEither
+
+instance (Applicative m) => Applicative (EitherT e m) where
+  pure x = EitherT $ (pure . pure) x
+  EitherT mEitherF <*> EitherT mEitherX =
+    EitherT $ (fmap (<*>) mEitherF) <*> mEitherX
+
+instance (Monad m) => Monad (EitherT e m) where
+  return = pure
+  EitherT mEitherX >>= f = EitherT $ do
+    eitherX <- mEitherX
+    case eitherX of
+      Left x -> pure $ Left x
+      Right x -> runEitherT $ f x
+
+swapEither :: Either l r -> Either r l
+swapEither (Left x) = Right x
+swapEither (Right x) = Left x
+
+swapEitherT :: (Functor m) => EitherT e m a -> EitherT a m e
+swapEitherT (EitherT mEitherX) =
+  EitherT $ fmap swapEither mEitherX
+
+eitherT :: Monad m => (a -> m c) -> (b -> m c) -> EitherT a m b -> m c
+eitherT aToMC bToMC (EitherT mEitherX) = do
+  eitherX <- mEitherX
+  case eitherX of
+    Left x -> aToMC x
+    Right x -> bToMC x
+
+--------------------------------------------------------------------------------
+
+newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }
+
+instance (Functor m) => Functor (ReaderT r m) where
+  fmap f (ReaderT rma) =
+    ReaderT $ (fmap . fmap) f rma
+
+instance (Applicative m) => Applicative (ReaderT r m) where
+  pure x = x & pure & pure & ReaderT
+  ReaderT f <*> ReaderT x = ReaderT $ fmap (<*>) f <*> x
+
+instance (Monad m) => Monad (ReaderT r m) where
+  return = pure
+  ReaderT rma >>= f =
+    ReaderT $ \r -> do
+      a <- rma r
+      runReaderT (f a) r