From 4238c33d643a0da3d82a3f45a07beb695ccdfa14 Mon Sep 17 00:00:00 2001
From: Abhijit Sarkar <contact@asarkar.com>
Date: Fri, 27 Dec 2024 20:11:56 -0800
Subject: [PATCH] Complete Monad

---
 fp-course-haskell.cabal |   2 +
 src/Monad.hs            | 142 ++++++++++++++++++++++++++++++++++++++++
 test/ApplicativeSpec.hs |  21 +++---
 test/MonadSpec.hs       |  57 ++++++++++++++++
 test/OptionalSpec.hs    |  10 +--
 test/Property.hs        |   5 +-
 test/ValidationSpec.hs  |   2 -
 7 files changed, 219 insertions(+), 20 deletions(-)
 create mode 100644 src/Monad.hs
 create mode 100644 test/MonadSpec.hs

diff --git a/fp-course-haskell.cabal b/fp-course-haskell.cabal
index e18b036..774c6d5 100644
--- a/fp-course-haskell.cabal
+++ b/fp-course-haskell.cabal
@@ -24,6 +24,7 @@ library
       ExactlyOne
       Functor
       List
+      Monad
       Optional
       Validation
   other-modules:
@@ -46,6 +47,7 @@ test-suite fp-course-test
       ApplicativeSpec
       FunctorSpec
       ListSpec
+      MonadSpec
       OptionalSpec
       Property
       SpecHook
diff --git a/src/Monad.hs b/src/Monad.hs
new file mode 100644
index 0000000..099949a
--- /dev/null
+++ b/src/Monad.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Monad where
+
+import Applicative (Applicative)
+import qualified Applicative as A
+import Core
+import ExactlyOne (ExactlyOne (..))
+import qualified ExactlyOne as EO
+import qualified Functor as F
+import List (List (..))
+import qualified List as L
+import Optional (Optional (..))
+import qualified Optional as O
+import qualified Prelude as P ((=<<))
+
+-- | All instances of the `Monad` type-class must satisfy one law. This law
+-- is not checked by the compiler. This law is given as:
+--
+-- * The law of associativity
+--   `∀f g x. g =<< (f =<< x) ≅ ((g =<<) . f) =<< x`
+class (Applicative f) => Monad f where
+  -- Pronounced, bind.
+  (=<<) :: (a -> f b) -> f a -> f b
+
+infixr 1 =<<
+
+-- | Binds a function on the ExactlyOne monad.
+--
+-- >>> (\x -> ExactlyOne(x+1)) =<< ExactlyOne 2
+-- ExactlyOne 3
+instance Monad ExactlyOne where
+  (=<<) :: (a -> ExactlyOne b) -> ExactlyOne a -> ExactlyOne b
+  (=<<) = EO.bindExactlyOne
+
+-- | Binds a function on a List.
+--
+-- >>> (\n -> n :. n :. Nil) =<< (1 :. 2 :. 3 :. Nil)
+-- [1,1,2,2,3,3]
+instance Monad List where
+  (=<<) :: (a -> List b) -> List a -> List b
+  (=<<) = L.flatMap
+
+-- | Binds a function on an Optional.
+--
+-- >>> (\n -> Full (n + n)) =<< Full 7
+-- Full 14
+instance Monad Optional where
+  (=<<) :: (a -> Optional b) -> Optional a -> Optional b
+  (=<<) = O.bindOptional
+
+-- | Binds a function on the reader ((->) t).
+--
+-- >>> ((*) =<< (+10)) 7
+-- 119
+instance Monad ((->) t) where
+  (=<<) :: (a -> (->) t b) -> (->) t a -> (->) t b
+  f =<< g = \x -> f (g x) x
+
+-- | Witness that all things with (=<<) and (<$>) also have (<*>).
+--
+-- >>> ExactlyOne (+10) <**> ExactlyOne 8
+-- ExactlyOne 18
+--
+-- >>> (+1) :. (*2) :. Nil <**> 1 :. 2 :. 3 :. Nil
+-- [2,3,4,2,4,6]
+--
+-- >>> Full (+8) <**> Full 7
+-- Full 15
+--
+-- >>> Empty <**> Full 7
+-- Empty
+--
+-- >>> Full (+8) <**> Empty
+-- Empty
+--
+-- >>> ((+) <**> (+10)) 3
+-- 16
+--
+-- >>> ((+) <**> (+5)) 3
+-- 11
+--
+-- >>> ((+) <**> (+5)) 1
+-- 7
+--
+-- >>> ((*) <**> (+10)) 3
+-- 39
+--
+-- >>> ((*) <**> (+2)) 3
+-- 15
+(<**>) :: (Monad f) => f (a -> b) -> f a -> f b
+(<**>) = (A.<*>)
+
+infixl 4 <**>
+
+-- | Flattens a combined structure to a single structure.
+--
+-- >>> join ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil)
+-- [1,2,3,1,2]
+--
+-- >>> join (Full Empty)
+-- Empty
+--
+-- >>> join (Full (Full 7))
+-- Full 7
+--
+-- >>> join (+) 7
+-- 14
+join :: (Monad f) => f (f a) -> f a
+join = (=<<) id
+
+-- | Implement a flipped version of @(=<<)@, however, use only
+-- @join@ and @(<$>)@.
+-- Pronounced, bind flipped.
+--
+-- >>> ((+10) >>= (*)) 7
+-- 119
+(>>=) :: (Monad f) => f a -> (a -> f b) -> f b
+a >>= f = join (f F.<$> a)
+
+infixl 1 >>=
+
+-- | Implement composition within the @Monad@ environment.
+-- Pronounced, kleisli composition.
+--
+-- >>> ((\n -> n :. n :. Nil) <=< (\n -> n+1 :. n+2 :. Nil)) 1
+-- [2,2,3,3]
+(<=<) :: (Monad f) => (b -> f c) -> (a -> f b) -> a -> f c
+f <=< g = \x -> f =<< g x
+
+infixr 1 <=<
+
+-----------------------
+-- SUPPORT LIBRARIES --
+-----------------------
+
+instance Monad IO where
+  (=<<) =
+    (P.=<<)
diff --git a/test/ApplicativeSpec.hs b/test/ApplicativeSpec.hs
index fd0c83a..623e543 100644
--- a/test/ApplicativeSpec.hs
+++ b/test/ApplicativeSpec.hs
@@ -1,6 +1,5 @@
 module ApplicativeSpec (spec) where
 
-import Applicative ()
 import qualified Applicative as A
 import ExactlyOne (ExactlyOne (..))
 import qualified Functor as F
@@ -16,13 +15,13 @@ spec = do
     prop "pure == ExactlyOne" $
       \x -> pure x `shouldBe` ExactlyOne (x :: Integer)
     it "Applying within ExactlyOne" $
-      ExactlyOne (+ 10) <*> ExactlyOne 8 `shouldBe` ExactlyOne (18 :: Int)
+      ExactlyOne (+ 10) A.<*> ExactlyOne 8 `shouldBe` ExactlyOne (18 :: Int)
 
   describe "List instance" $ do
     prop "pure" $
       \x -> pure x `shouldBe` (x :: Integer) :. Nil
     it "<*>" $
-      (+ 1) :. (* 2) :. Nil <*> L.listh [1, 2, 3] `shouldBe` L.listh [2 :: Int, 3, 4, 2, 4, 6]
+      (+ 1) :. (* 2) :. Nil A.<*> L.listh [1, 2, 3] `shouldBe` L.listh [2 :: Int, 3, 4, 2, 4, 6]
 
   describe "lift1" $ do
     it "ExactlyOne" $
@@ -36,23 +35,23 @@ spec = do
     prop "pure" $
       \x -> pure x `shouldBe` Full (x :: Integer)
     it "Full <*> Full" $
-      Full (+ 8) <*> Full 7 `shouldBe` Full (15 :: Int)
+      Full (+ 8) A.<*> Full 7 `shouldBe` Full (15 :: Int)
     it "Empty <*> Full" $
-      Empty <*> Full "tilt" `shouldBe` (Empty :: Optional Integer)
+      Empty A.<*> Full "tilt" `shouldBe` (Empty :: Optional Integer)
     it "Full <*> Empty" $
-      Full (+ 8) <*> Empty `shouldBe` (Empty :: Optional Int)
+      Full (+ 8) A.<*> Empty `shouldBe` (Empty :: Optional Int)
 
   describe "Function instance" $ do
     it "addition" $
-      ((+) <*> (+ 10)) 3 `shouldBe` (16 :: Int)
+      ((+) A.<*> (+ 10)) 3 `shouldBe` (16 :: Int)
     it "more addition" $
-      ((+) <*> (+ 5)) 3 `shouldBe` (11 :: Int)
+      ((+) A.<*> (+ 5)) 3 `shouldBe` (11 :: Int)
     it "even more addition" $
-      ((+) <*> (+ 5)) 1 `shouldBe` (7 :: Int)
+      ((+) A.<*> (+ 5)) 1 `shouldBe` (7 :: Int)
     it "addition and multiplication" $
-      ((*) <*> (+ 10)) 3 `shouldBe` (39 :: Int)
+      ((*) A.<*> (+ 10)) 3 `shouldBe` (39 :: Int)
     it "more addition and multiplcation" $
-      ((*) <*> (+ 2)) 3 `shouldBe` (15 :: Int)
+      ((*) A.<*> (+ 2)) 3 `shouldBe` (15 :: Int)
     prop "pure" $
       \x y -> pure x (y :: Integer) `shouldBe` (x :: Integer)
 
diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs
new file mode 100644
index 0000000..c50cb3c
--- /dev/null
+++ b/test/MonadSpec.hs
@@ -0,0 +1,57 @@
+module MonadSpec (spec) where
+
+import ExactlyOne (ExactlyOne (..))
+import List (List (..))
+import qualified Monad as M
+import Optional (Optional (..))
+import Test.Hspec
+
+spec :: Spec
+spec = do
+  describe "(=<<)" $ do
+    it "ExactlyOne" $
+      ((\x -> ExactlyOne (x + 1)) M.=<< ExactlyOne 2) `shouldBe` ExactlyOne (3 :: Int)
+    it "List" $
+      ((\n -> n :. n :. Nil) M.=<< (1 :. 2 :. 3 :. Nil)) `shouldBe` ((1 :: Int) :. 1 :. 2 :. 2 :. 3 :. 3 :. Nil)
+    it "Optional" $
+      ((\n -> Full (n + n)) M.=<< Full 7) `shouldBe` Full (14 :: Int)
+    it "(->)" $
+      ((*) M.=<< (+ 10)) 7 `shouldBe` (119 :: Int)
+
+  describe "<**>" $ do
+    it "ExactlyOne" $
+      ExactlyOne (+ 10) M.<**> ExactlyOne 8 `shouldBe` ExactlyOne (18 :: Int)
+    it "List" $
+      (+ 1) :. (* 2) :. Nil M.<**> 1 :. 2 :. 3 :. Nil `shouldBe` ((2 :: Int) :. 3 :. 4 :. 2 :. 4 :. 6 :. Nil)
+    it "Optional" $
+      Full (+ 8) M.<**> Full 7 `shouldBe` Full (15 :: Int)
+    it "Optional - empty function" $
+      Empty M.<**> Full (7 :: Int) `shouldBe` (Empty :: Optional Int)
+    it "Optional - empty value" $
+      Full (+ 8) M.<**> Empty `shouldBe` (Empty :: Optional Int)
+    it "(->) 1" $
+      ((+) M.<**> (+ 10)) 3 `shouldBe` (16 :: Int)
+    it "(->) 2" $
+      ((+) M.<**> (+ 5)) 3 `shouldBe` (11 :: Int)
+    it "(->) 3" $
+      ((+) M.<**> (+ 5)) 1 `shouldBe` (7 :: Int)
+    it "(->) 4" $
+      ((*) M.<**> (+ 10)) 3 `shouldBe` (39 :: Int)
+    it "(->) 5" $
+      ((*) M.<**> (+ 2)) 3 `shouldBe` (15 :: Int)
+
+  describe "join" $ do
+    it "List" $
+      M.join ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) `shouldBe` ((1 :: Int) :. 2 :. 3 :. 1 :. 2 :. Nil)
+    it "Optional with Empty" $
+      M.join (Full Empty) `shouldBe` (Empty :: Optional Integer)
+    it "Optional all Full" $
+      M.join (Full (Full 7)) `shouldBe` Full (7 :: Int)
+    it "(->)" $
+      M.join (+) 7 `shouldBe` (14 :: Int)
+
+  it "(>>=)" $
+    ((+ 10) M.>>= (*)) 7 `shouldBe` (119 :: Int)
+
+  it "kleislyComposition" $
+    ((\n -> n :. n :. Nil) M.<=< (\n -> n + 1 :. n + 2 :. Nil)) 1 `shouldBe` ((2 :: Int) :. 2 :. 3 :. 3 :. Nil)
diff --git a/test/OptionalSpec.hs b/test/OptionalSpec.hs
index 500626b..dd1884b 100644
--- a/test/OptionalSpec.hs
+++ b/test/OptionalSpec.hs
@@ -1,6 +1,6 @@
 module OptionalSpec (spec) where
 
-import Optional (Optional (..), (<+>))
+import Optional (Optional (..))
 import qualified Optional as O
 import Test.Hspec
 
@@ -30,13 +30,13 @@ spec = do
 
   describe "<+>" $ do
     it "first Full" $
-      Full 8 <+> Empty `shouldBe` Full (8 :: Int)
+      Full 8 O.<+> Empty `shouldBe` Full (8 :: Int)
     it "both Full" $
-      Full 8 <+> Full 9 `shouldBe` Full (8 :: Int)
+      Full 8 O.<+> Full 9 `shouldBe` Full (8 :: Int)
     it "first Empty" $
-      Empty <+> Full 9 `shouldBe` Full (9 :: Int)
+      Empty O.<+> Full 9 `shouldBe` Full (9 :: Int)
     it "both empty" $
-      Empty <+> Empty `shouldBe` (Empty :: Optional Integer)
+      Empty O.<+> Empty `shouldBe` (Empty :: Optional Integer)
 
   describe "optional" $ do
     it "replaces full data constructor" $
diff --git a/test/Property.hs b/test/Property.hs
index 3be787a..bb960ad 100644
--- a/test/Property.hs
+++ b/test/Property.hs
@@ -2,12 +2,13 @@
 
 module Property where
 
-import List (List, listh)
+import List (List)
+import qualified List as L
 import Test.QuickCheck
 import Validation (Validation (..))
 
 instance (Arbitrary a) => Arbitrary (List a) where
-  arbitrary = listh <$> arbitrary
+  arbitrary = L.listh <$> arbitrary
 
 instance (Arbitrary a) => Arbitrary (Validation a) where
   arbitrary =
diff --git a/test/ValidationSpec.hs b/test/ValidationSpec.hs
index ed427a7..cef838c 100644
--- a/test/ValidationSpec.hs
+++ b/test/ValidationSpec.hs
@@ -6,8 +6,6 @@ import Test.Hspec.QuickCheck
 import Validation (Validation (..))
 import qualified Validation as V
 
--- f :: (Integral a) => a -> Validation a
-
 spec :: Spec
 spec = do
   describe "isError" $ do