feat: Progress with Ch15 exercises, nearly done

Author: OlaoluwaM

hffp.cabal

@@ -16,25 +16,24 @@ extra-source-files:
 
 library
   exposed-modules:
-      Ch14.Addition
-      Ch14.Morse
-      Ch8.Playground
-      Ch11.Cipher
-      Ch9.Cipher
-  other-modules:
       Ch10.Playground
+      Ch11.Cipher
       Ch11.HuttonsRazor
       Ch11.Phone
       Ch11.PhoneAlt
       Ch11.Playground
       Ch12.Playground
       Ch13.Person
       Ch13.Playground
+      Ch14.Addition
+      Ch14.Morse
       Ch15.Bull
+      Ch15.Exercise
       Ch15.Listy
       Ch15.ListyInstances
       Ch15.Playground
-      Ch15.Semigroups
+      Ch8.Playground
+      Ch9.Cipher
       Ch9.Playground
       Ch9.StdFunc
       Lib
@@ -78,6 +77,7 @@ test-suite hffp-test
       Ch14.Identity
       Ch14.MorseSpec
       Ch14.Trivial
+      Ch15.ExerciseSpec
       Ch8.WordNumberSpec
   hs-source-dirs:
       test

package.yaml

@@ -42,12 +42,6 @@ library:
     - containers
     - hspec
     - QuickCheck
-  exposed-modules:
-    - Ch14.Addition
-    - Ch14.Morse
-    - Ch8.Playground
-    - Ch11.Cipher
-    - Ch9.Cipher
 
 executables:
   hffp:

src/Ch15/Semigroups.hs src/Ch15/Exercise.hs

@@ -1,4 +1,4 @@
-module Ch15.Semigroups where
+module Ch15.Exercise where
 
 import Test.QuickCheck hiding (Failure, Success)
 
@@ -10,17 +10,20 @@ data Trivial = Trivial
 instance Semigroup Trivial where
     _ <> _ = Trivial
 
+instance Monoid Trivial where
+    mempty = Trivial
+
 instance Arbitrary Trivial where
     arbitrary = pure Trivial
 
-semigroupAssocProp :: (Eq a, Semigroup a) => a -> a -> a -> Bool
-semigroupAssocProp a b c = a <> (b <> c) == (a <> b) <> c
-
 newtype Identity a = Identity a deriving (Eq, Show)
 
 instance (Semigroup a) => Semigroup (Identity a) where
     (Identity a) <> (Identity b) = Identity $ a <> b
 
+instance (Monoid a) => Monoid (Identity a) where
+    mempty = Identity mempty
+
 instance (Arbitrary a) => Arbitrary (Identity a) where
     arbitrary = Identity <$> arbitrary
 
@@ -29,6 +32,9 @@ data Two a b = Two a b deriving (Eq, Show)
 instance (Semigroup a, Semigroup b) => Semigroup (Two a b) where
     (Two a b) <> (Two a' b') = Two (a <> a') (b <> b')
 
+instance (Monoid a, Monoid b) => Monoid (Two a b) where
+    mempty = Two mempty mempty
+
 instance (Arbitrary a, Arbitrary b) => Arbitrary (Two a b) where
     arbitrary = Two <$> arbitrary <*> arbitrary
 
@@ -37,6 +43,9 @@ data Three a b c = Three a b c deriving (Eq, Show)
 instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (Three a b c) where
     (Three a b c) <> (Three a' b' c') = Three (a <> a') (b <> b') (c <> c')
 
+instance (Monoid a, Monoid b, Monoid c) => Monoid (Three a b c) where
+    mempty = Three mempty mempty mempty
+
 instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (Three a b c) where
     arbitrary = Three <$> arbitrary <*> arbitrary <*> arbitrary
 
@@ -45,6 +54,9 @@ data Four a b c d = Four a b c d deriving (Eq, Show)
 instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) => Semigroup (Four a b c d) where
     (Four a b c d) <> (Four a' b' c' d') = Four (a <> a') (b <> b') (c <> c') (d <> d')
 
+instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (Four a b c d) where
+    mempty = Four mempty mempty mempty mempty
+
 instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (Four a b c d) where
     arbitrary = Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 
@@ -53,6 +65,9 @@ newtype BoolConj = BoolConj Bool deriving (Eq, Show)
 instance Semigroup BoolConj where
     (BoolConj b) <> (BoolConj b') = BoolConj $ b && b'
 
+instance Monoid BoolConj where
+    mempty = BoolConj $ getAll (mempty :: All)
+
 instance Arbitrary BoolConj where
     arbitrary = BoolConj <$> arbitrary
 
@@ -61,6 +76,9 @@ newtype BoolDisj = BoolDisj Bool deriving (Eq, Show)
 instance Semigroup BoolDisj where
     (BoolDisj b) <> (BoolDisj b') = BoolDisj $ b || b'
 
+instance Monoid BoolDisj where
+    mempty = BoolDisj $ getAny (mempty :: Any)
+
 instance Arbitrary BoolDisj where
     arbitrary = BoolDisj <$> arbitrary
 
@@ -88,9 +106,6 @@ instance (CoArbitrary a, Arbitrary b) => Arbitrary (Combine a b) where
 instance Show (Combine a b) where
     show _ = "Combine (a -> b)"
 
-combineSemigroupAssocProp :: (Eq b, Semigroup b) => Combine a b -> Combine a b -> Combine a b -> a -> Bool
-combineSemigroupAssocProp f g h a = unCombine (f <> (g <> h)) a == unCombine ((f <> g) <> h) a
-
 newtype Comp a = Comp {unComp :: a -> a}
 
 instance (Semigroup a) => Semigroup (Comp a) where
@@ -102,9 +117,6 @@ instance (CoArbitrary a, Arbitrary a) => Arbitrary (Comp a) where
 instance Show (Comp a) where
     show _ = "Comp (a -> a)"
 
-compSemigroupAssocProp :: (Eq a, Semigroup a) => Comp a -> Comp a -> Comp a -> a -> Bool
-compSemigroupAssocProp f g h a = unComp (f <> (g <> h)) a == unComp ((f <> g) <> h) a
-
 data Validation a b = Failure a | Success b deriving (Eq, Show)
 
 instance (Semigroup a) => Semigroup (Validation a b) where
@@ -124,51 +136,3 @@ failure = Failure
 
 success :: Int -> Validation String Int
 success = Success
-
--- Move this to the test directory
-main :: IO ()
-main = do
-    putStr "Trivial Semigroup Assoc Prop: "
-    quickCheck (semigroupAssocProp @Trivial)
-
-    putStr "Identity a Assoc Prop: "
-    quickCheck (semigroupAssocProp @(Identity (Sum Int)))
-
-    putStr "Identity a 2 Assoc Prop: "
-    quickCheck (semigroupAssocProp @(Identity (Product Int)))
-
-    putStr "Identity a 3 Assoc Prop: "
-    quickCheck (semigroupAssocProp @(Identity (First (Maybe Int))))
-
-    putStr "Two Assoc Prop: "
-    quickCheck (semigroupAssocProp @(Two (Sum Int) String))
-
-    putStr "Two Assoc Prop: "
-    quickCheck (semigroupAssocProp @(Two (Sum Int) (Product Int)))
-
-    putStr "Three Assoc Prop: "
-    quickCheck (semigroupAssocProp @(Three Any (Sum Int) (Product Int)))
-
-    putStr "Four Assoc Prop: "
-    quickCheck (semigroupAssocProp @(Four (First (Maybe String)) (Last (Maybe Bool)) All (Product Int)))
-
-    putStr "BoolConj Assoc Prop: "
-    quickCheck (semigroupAssocProp @BoolConj)
-
-    putStr "BoolDisj Assoc Prop: "
-    quickCheck (semigroupAssocProp @BoolDisj)
-
-    putStr "Or Assoc Prop: "
-    quickCheck (semigroupAssocProp @(Or Int String))
-
-    putStr "Combine Assoc Prop: "
-    quickCheck (combineSemigroupAssocProp @(Sum Int) @Int)
-
-    putStr "Comp Assoc Prop: "
-    quickCheck (compSemigroupAssocProp @(Sum Int))
-
-    putStrLn ""
-    print $ success 1 <> failure "blah"
-    print $ failure "woot" <> failure "blah"
-    print $ success 1 <> success 2
-    print $ failure "woot" <> success 2

src/Ch15/Exercises.md

@@ -0,0 +1,57 @@
+module Ch15.ExerciseSpec where
+
+import Ch15.Exercise
+import Ch15.Playground
+
+import Test.Hspec
+import Test.Hspec.QuickCheck
+
+import Data.Monoid
+
+semigroupAssocProp :: (Eq a, Semigroup a) => a -> a -> a -> Bool
+semigroupAssocProp a b c = a <> (b <> c) == (a <> b) <> c
+
+compSemigroupAssocProp :: (Eq a, Semigroup a) => Comp a -> Comp a -> Comp a -> a -> Bool
+compSemigroupAssocProp f g h a = unComp (f <> (g <> h)) a == unComp ((f <> g) <> h) a
+
+combineSemigroupAssocProp :: (Eq b, Semigroup b) => Combine a b -> Combine a b -> Combine a b -> a -> Bool
+combineSemigroupAssocProp f g h a = unCombine (f <> (g <> h)) a == unCombine ((f <> g) <> h) a
+
+monoidLawsProp :: (Eq m, Monoid m) => m -> m -> m -> Bool
+monoidLawsProp a b c = semigroupAssocProp a b c && monoidLeftIdentityProp a && monoidRightIdentityProp a
+
+spec :: Spec
+spec = do
+    describe "Semigroup Assoc prop tests for datatypes" $ do
+        prop "Trivial" $ semigroupAssocProp @Trivial
+        prop "Identity a" $ semigroupAssocProp @(Identity (Sum Int))
+        prop "Identity a (2)" $ semigroupAssocProp @(Identity (Product Int))
+        prop "Identity a (3)" $ semigroupAssocProp @(Identity (First (Maybe Int)))
+        prop "Two a b" $ semigroupAssocProp @(Two (Sum Int) String)
+        prop "Two a b (2)" $ semigroupAssocProp @(Two (Sum Int) (Product Int))
+        prop "Three a b c" $ semigroupAssocProp @(Three Any (Sum Int) (Product Int))
+        prop "Four a b c d" $ semigroupAssocProp @(Four (First (Maybe String)) (Last (Maybe Bool)) All (Product Int))
+        prop "BoolConj" $ semigroupAssocProp @BoolConj
+        prop "BoolDisj" $ semigroupAssocProp @BoolDisj
+        prop "Or a b" $ semigroupAssocProp @(Or Int String)
+        prop "Combine a b" $ combineSemigroupAssocProp @(Sum Int) @Int
+        prop "Comp a" $ compSemigroupAssocProp @(Sum Int)
+
+        it "Validation a" $
+            and
+                [ success 1 <> failure "blah" == Success 1
+                , failure "woot" <> failure "blah" == Failure "wootblah"
+                , success 1 <> success 2 == Success 1
+                , failure "woot" <> success 2 == Success 2
+                ]
+    describe "Monoid Laws tests for datatypes" $ do
+        prop "Trivial" $ monoidLawsProp @Trivial
+        prop "Identity a" $ monoidLawsProp @(Identity (Sum Int))
+        prop "Identity a (2)" $ monoidLawsProp @(Identity (Product Int))
+        prop "Identity a (3)" $ monoidLawsProp @(Identity (First (Maybe Int)))
+        prop "Two a b" $ monoidLawsProp @(Two (Sum Int) String)
+        prop "Two a b (2)" $ monoidLawsProp @(Two (Sum Int) (Product Int))
+        prop "Three a b c" $ monoidLawsProp @(Three Any (Sum Int) (Product Int))
+        prop "Four a b c d" $ monoidLawsProp @(Four (First (Maybe String)) (Last (Maybe Bool)) All (Product Int))
+        prop "BoolConj" $ monoidLawsProp @BoolConj
+        prop "BoolDisj" $ monoidLawsProp @BoolDisj