subtree(users/wpcarro): docking briefcase at '24f5a642' r/3226

git-subtree-dir: users/wpcarro
git-subtree-mainline: 464bbcb15c09813172c79820bcf526bb10cf4208
git-subtree-split: 24f5a642af3aa1627bbff977f0a101907a02c69f
Change-Id: I6105b3762b79126b3488359c95978cadb3efa789

1 files changed, 131 insertions, 0 deletions

diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/traversable.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/traversable.hs
new file mode 100644
index 000000000000..5dc4ea411bc2
--- /dev/null
+++ b/users/wpcarro/scratch/haskell-programming-from-first-principles/traversable.hs
@@ -0,0 +1,131 @@
+module TraversableScratch where
+
+import qualified Data.Foldable as F
+
+import Test.QuickCheck
+
+newtype Identity a = Identity a
+  deriving (Eq, Ord, Show)
+
+instance Functor Identity where
+  fmap f (Identity x) = Identity (f x)
+
+instance Foldable Identity where
+  foldMap f (Identity x) = f x
+
+instance Traversable Identity where
+  traverse f (Identity x) = Identity <$> f x
+
+--------------------------------------------------------------------------------
+
+data Optional a
+  = Nada
+  | Some a
+  deriving (Eq, Show)
+
+instance Functor Optional where
+  fmap f Nada = Nada
+  fmap f (Some x) = Some (f x)
+
+instance Foldable Optional where
+  foldMap f Nada = mempty
+  foldMap f (Some x) = f x
+
+instance Traversable Optional where
+  traverse f Nada = pure Nada
+  traverse f (Some x) = Some <$> f x
+
+--------------------------------------------------------------------------------
+
+data List a = Nil | Cons a (List a) deriving (Eq, Show)
+
+instance Functor List where
+  fmap _ Nil = Nil
+  fmap f (Cons x xs) = Cons (f x) (fmap f xs)
+
+instance Foldable List where
+  foldMap f Nil = mempty
+  foldMap f (Cons x xs) = mappend (f x) (foldMap f xs)
+
+instance Traversable List where
+  sequenceA Nil = pure Nil
+  sequenceA (Cons x xs) = Cons <$> x <*> sequenceA xs
+
+--------------------------------------------------------------------------------
+
+data Three a b c = Three a b c
+  deriving (Eq, Show)
+
+instance Functor (Three a b) where
+  fmap f (Three x y z) = Three x y (f z)
+
+instance Foldable (Three a b) where
+  foldMap f (Three _ _ z) = f z
+
+instance Traversable (Three a b) where
+  sequenceA (Three x y z) = (\z' -> Three x y z') <$> z
+
+--------------------------------------------------------------------------------
+
+data Pair a b = Pair a b
+  deriving (Eq, Show)
+
+instance Functor (Pair a) where
+  fmap f (Pair x y) = Pair x (f y)
+
+instance Foldable (Pair a) where
+  foldMap f (Pair x y) = f y
+
+instance Traversable (Pair a) where
+  sequenceA (Pair x y) = (\y' -> Pair x y') <$> y
+
+--------------------------------------------------------------------------------
+
+data Big a b = Big a b b
+  deriving (Eq, Show)
+
+instance Functor (Big a) where
+  fmap f (Big x y z) = Big x (f y) (f z)
+
+instance Foldable (Big a) where
+  foldMap f (Big x y z) = f y <> f z
+
+instance Traversable (Big a) where
+  sequenceA (Big x y z) = (\y' z' -> Big x y' z') <$> y <*> z
+
+--------------------------------------------------------------------------------
+
+data Bigger a b = Bigger a b b b
+  deriving (Eq, Show)
+
+instance Functor (Bigger a) where
+  fmap f (Bigger w x y z) = Bigger w (f x) (f y) (f z)
+
+instance Foldable (Bigger a) where
+  foldMap f (Bigger w x y z) = f x <> f y <> f z
+
+instance Traversable (Bigger a) where
+  sequenceA (Bigger w x y z) = (\x' y' z' -> Bigger w x' y' z') <$> x <*> y <*> z
+
+--------------------------------------------------------------------------------
+
+data Tree a
+  = Empty
+  | Leaf a
+  | Node (Tree a) a (Tree a)
+  deriving (Eq, Show)
+
+instance Functor Tree where
+  fmap f Empty = Empty
+  fmap f (Leaf x) = Leaf (f x)
+  fmap f (Node lhs x rhs) = Node (fmap f lhs) (f x) (fmap f rhs)
+
+instance Foldable Tree where
+  foldMap f Empty = mempty
+  foldMap f (Leaf x) = f x
+  foldMap f (Node lhs x rhs) = (foldMap f lhs) <> (f x) <> (foldMap f rhs)
+
+instance Traversable Tree where
+  sequenceA Empty = pure Empty
+  sequenceA (Leaf x) = Leaf <$> x
+  sequenceA (Node lhs x rhs) = Node <$> sequenceA lhs <*> x <*> sequenceA rhs