Complete Traversable

README.md

@@ -26,7 +26,7 @@ After this, we recommend the following progression of modules:
 * [Comonad](src/Comonad.hs)
 * [Contravariant](src/Contravariant.hs)
 * [Compose](src/Compose.hs)
-* Traversable
+* [Traversable](src/Traversable.hs)
 * ListZipper
 * Parser *(see also Person for the parsing rules)*
 * MoreParser

fp-course-haskell.cabal

@@ -33,6 +33,7 @@ library
       Optional
       State
       StateT
+      Traversable
       Validation
   other-modules:
       Paths_fp_course_haskell
@@ -65,6 +66,7 @@ test-suite fp-course-test
       SpecHook
       StateSpec
       StateTSpec
+      TraversableSpec
       ValidationSpec
       Paths_fp_course_haskell
   hs-source-dirs:

src/Compose.hs

@@ -13,6 +13,13 @@ import Monad (Monad, (=<<))
 
 -- Exactly one of these exercises will not be possible to achieve. Determine which.
 
+{-
+The way to think about Compose is that it has two types, outer f and inner g,
+and the operations that're possible on these types help us implement the
+instances of Compose for various type classes.
+For example, if f is a Functor, we can fmap over it.
+-}
+
 newtype Compose f g a
   = Compose (f (g a))
   deriving stock (Show, Eq)
@@ -22,6 +29,7 @@ instance
   (Functor f, Functor g) =>
   Functor (Compose f g)
   where
+  (<$>) :: (a -> b) -> Compose f g a -> Compose f g b
   f <$> Compose g = Compose ((f F.<$>) F.<$> g)
 
 instance

src/Traversable.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Traversable where
+
+import Applicative (Applicative)
+import qualified Applicative as A
+import Compose (Compose (..))
+import Core
+import ExactlyOne (ExactlyOne (..))
+import qualified ExactlyOne as EO
+import Functor (Functor)
+import qualified Functor as F
+import List (List (..))
+import qualified List as L
+import Optional (Optional (..))
+
+-- | All instances of the `Traversable` type-class must satisfy three laws. These
+-- laws are not checked by the compiler. These laws are given as:
+--
+-- * The law of naturality
+--   `∀f g. f . traverse g ≅ traverse (f . g)`
+--
+-- * The law of identity
+--   `∀x. traverse ExactlyOne x ≅ ExactlyOne x`
+--
+-- * The law of composition
+--   `∀f g. traverse ((g <$>) . f) ≅ (traverse g <$>) . traverse f`
+class (Functor t) => Traversable t where
+  traverse :: (Applicative k) => (a -> k b) -> t a -> k (t b)
+
+instance Traversable List where
+  traverse :: (Applicative k) => (a -> k b) -> List a -> k (List b)
+  traverse f = L.foldRight (\a b -> (:.) F.<$> f a A.<*> b) (A.pure Nil)
+
+instance Traversable ExactlyOne where
+  traverse :: (Applicative k) => (a -> k b) -> ExactlyOne a -> k (ExactlyOne b)
+  traverse f a = ExactlyOne F.<$> f (EO.runExactlyOne a)
+
+instance Traversable Optional where
+  traverse :: (Applicative k) => (a -> k b) -> Optional a -> k (Optional b)
+  traverse _ Empty = A.pure Empty
+  traverse f (Full x) = Full F.<$> f x
+
+-- | Sequences a traversable value of structures to a structure of a traversable value.
+--
+-- >>> sequenceA (ExactlyOne 7 :. ExactlyOne 8 :. ExactlyOne 9 :. Nil)
+-- ExactlyOne [7,8,9]
+--
+-- >>> sequenceA (Full (ExactlyOne 7))
+-- ExactlyOne (Full 7)
+--
+-- >>> sequenceA (Full (*10)) 6
+-- Full 60
+sequenceA :: (Applicative k, Traversable t) => t (k a) -> k (t a)
+sequenceA = traverse id
+
+instance
+  (Traversable f, Traversable g) =>
+  Traversable (Compose f g)
+  where
+  -- Implement the traverse function for a Traversable instance for Compose
+  traverse :: (Applicative k) => (a -> k b) -> Compose f g a -> k (Compose f g b)
+  traverse f (Compose a) = Compose F.<$> traverse (traverse f) a
+
+-- | The `Product` data type contains one value from each of the two type constructors.
+data Product f g a
+  = Product (f a) (g a)
+  deriving stock (Show, Eq)
+
+instance
+  (Functor f, Functor g) =>
+  Functor (Product f g)
+  where
+  -- Implement the (<$>) function for a Functor instance for Product
+  (<$>) :: (a -> b) -> Product f g a -> Product f g b
+  f' <$> Product f g = Product (f' F.<$> f) (f' F.<$> g)
+
+instance
+  (Traversable f, Traversable g) =>
+  Traversable (Product f g)
+  where
+  -- Implement the traverse function for a Traversable instance for Product
+  traverse :: (Applicative k) => (a -> k b) -> Product f g a -> k (Product f g b)
+  traverse f' (Product f g) = A.lift2 Product (traverse f' f) (traverse f' g)
+
+-- | The `Coproduct` data type contains one value from either of the two type constructors.
+data Coproduct f g a
+  = InL (f a)
+  | InR (g a)
+  deriving stock (Show, Eq)
+
+instance
+  (Functor f, Functor g) =>
+  Functor (Coproduct f g)
+  where
+  -- Implement the (<$>) function for a Functor instance for Coproduct
+  (<$>) :: (a -> b) -> Coproduct f g a -> Coproduct f g b
+  f' <$> InL f = InL (f' F.<$> f)
+  f' <$> InR g = InR (f' F.<$> g)
+
+instance
+  (Traversable f, Traversable g) =>
+  Traversable (Coproduct f g)
+  where
+  -- Implement the traverse function for a Traversable instance for Coproduct
+  traverse :: (Applicative k) => (a -> k b) -> Coproduct f g a -> k (Coproduct f g b)
+  traverse f' (InL f) = InL F.<$> traverse f' f
+  traverse f' (InR g) = InR F.<$> traverse f' g

test/ComposeSpec.hs

@@ -1,7 +1,5 @@
 module ComposeSpec (spec) where
 
--- import qualified Compose as C
-
 import qualified Applicative as A
 import Compose (Compose (..))
 import Contravariant (Predicate (..))

test/TraversableSpec.hs

@@ -0,0 +1,85 @@
+module TraversableSpec (spec) where
+
+import Compose (Compose (..))
+import ExactlyOne (ExactlyOne (..))
+import qualified Functor as F
+import List (List (..))
+import qualified List as L
+import Optional (Optional (..))
+import Test.Hspec
+import Traversable (Coproduct (..), Product (..))
+import qualified Traversable as T
+
+spec :: Spec
+spec = do
+  describe "listTest" $ do
+    it "traverse on empty list" $
+      T.traverse (\a -> Full (a * 2)) (Nil :: List Int) `shouldBe` Full Nil
+    it "traverse on non-empty list" $
+      T.traverse (\a -> Full (a * 2)) (L.listh [1, 2, 3]) `shouldBe` Full (L.listh [2, 4, 6])
+
+  describe "exactlyOneTest" $ do
+    it "traverse on ExactlyOne" $
+      T.traverse (\a -> Full (a * 2)) (ExactlyOne 3) `shouldBe` Full (ExactlyOne 6)
+
+  describe "optionalTest" $ do
+    it "traverse on Empty" $
+      T.traverse (\a -> ExactlyOne (a * 2)) Empty `shouldBe` ExactlyOne Empty
+    it "traverse on Full" $
+      T.traverse (\a -> ExactlyOne (a * 2)) (Full 5) `shouldBe` ExactlyOne (Full 10)
+
+  describe "sequenceATest" $ do
+    it "on List over ExactlyOne" $
+      T.sequenceA (L.listh [ExactlyOne 7, ExactlyOne 8, ExactlyOne 9]) `shouldBe` ExactlyOne (L.listh [7, 8, 9])
+    it "on Optional over ExactlyOne" $
+      T.sequenceA (Full (ExactlyOne 7)) `shouldBe` ExactlyOne (Full 7)
+    it "on Optional over function" $
+      T.sequenceA (Full (* 10)) 6 `shouldBe` Full 60
+
+  describe "composeTest" $ do
+    let fmap2 f = ((f <$>) <$>)
+    let fullListOfInts = Full (L.listh [1, 2, 3])
+    let listOfExactlyOnes = L.listh [ExactlyOne 1, ExactlyOne 2, ExactlyOne 3]
+    let cfli = Compose fullListOfInts
+    let traversedCfli = Compose $ (* 2) `fmap2` fullListOfInts
+    let clei = Compose listOfExactlyOnes
+    let traversedClei = Compose $ (* 2) `fmap2` listOfExactlyOnes
+
+    it "traverse on Compose Optional List Int" $
+      T.traverse (\a -> ExactlyOne (a * 2)) cfli `shouldBe` ExactlyOne traversedCfli
+    it "traverse on Compose List ExactlyOne Int" $
+      T.traverse (\a -> Full (a * 2)) clei `shouldBe` Full traversedClei
+
+  describe "productTest" $ do
+    let listOfInts = L.listh [1, 2, 3]
+
+    describe "productFunctorTest" $ do
+      it "fmap on Product Optional List Int" $
+        (* 2) F.<$> Product (Full 4) listOfInts `shouldBe` Product (Full 8) ((* 2) F.<$> listOfInts)
+      it "fmap on Product ExactlyOne Optional Int" $
+        (* 2) F.<$> Product (ExactlyOne 4) Empty `shouldBe` Product (ExactlyOne 8) Empty
+
+    describe "productTraversableTest" $ do
+      it "traverse on Product Optional List Int" $ do
+        let pdt = Product (Full 4) listOfInts
+        let productTimesTwo = Product (Full 8) ((* 2) F.<$> listOfInts)
+        T.traverse (\a -> ExactlyOne (a * 2)) pdt `shouldBe` ExactlyOne productTimesTwo
+
+  describe "coProductTest" $ do
+    let listOfInts = L.listh [1, 2, 3]
+    let inL = InL (Full 4) :: Coproduct Optional List Int
+    let inLTimesTwo = InL (Full 8) :: Coproduct Optional List Int
+    let inR = InR listOfInts :: Coproduct Optional List Int
+    let inRTimesTwo = InR ((* 2) F.<$> listOfInts) :: Coproduct Optional List Int
+
+    describe "coProductFunctorTest" $ do
+      it "fmap on InL Optional Int" $
+        (* 2) F.<$> inL `shouldBe` inLTimesTwo
+      it "fmap on InR ExactlyOne Int" $
+        (* 2) F.<$> inR `shouldBe` inRTimesTwo
+
+    describe "coProductTraversableTest" $ do
+      it "traverse on InL Optional Int" $
+        T.traverse (\a -> ExactlyOne (a * 2)) inL `shouldBe` ExactlyOne inLTimesTwo
+      it "traverse on InR List Int" $
+        T.traverse (\a -> Full (a * 2)) inR `shouldBe` Full inRTimesTwo