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, 107 insertions, 0 deletions

diff --git a/users/wpcarro/scratch/haskell-programming-from-first-principles/foldable.hs b/users/wpcarro/scratch/haskell-programming-from-first-principles/foldable.hs
new file mode 100644
index 000000000000..5b59d9e9ba50
--- /dev/null
+++ b/users/wpcarro/scratch/haskell-programming-from-first-principles/foldable.hs
@@ -0,0 +1,107 @@
+module FoldableScratch where
+
+import Data.Function ((&))
+
+--------------------------------------------------------------------------------
+
+sum :: (Foldable t, Num a) => t a -> a
+sum xs =
+  foldr (+) 0 xs
+
+product :: (Foldable t, Num a) => t a -> a
+product xs =
+  foldr (*) 1 xs
+
+elem :: (Foldable t, Eq a) => a -> t a -> Bool
+elem y xs =
+  foldr (\x acc -> if acc then acc else y == x) False xs
+
+minimum :: (Foldable t, Ord a) => t a -> Maybe a
+minimum xs =
+  foldr (\x acc ->
+           case acc of
+             Nothing   -> Just x
+             Just curr -> Just (min curr x)) Nothing xs
+
+maximum :: (Foldable t, Ord a) => t a -> Maybe a
+maximum xs =
+  foldr (\x acc ->
+           case acc of
+             Nothing   -> Nothing
+             Just curr -> Just (max curr x)) Nothing xs
+
+-- TODO: How could I use QuickCheck to see if Prelude.null and this null return
+-- the same results for the same inputs?
+null :: (Foldable t) => t a -> Bool
+null xs =
+  foldr (\_ _ -> False) True xs
+
+length :: (Foldable t) => t a -> Int
+length xs =
+  foldr (\_ acc -> acc + 1) 0 xs
+
+toList :: (Foldable t) => t a -> [a]
+toList xs =
+  reverse $ foldr (\x acc -> x : acc) [] xs
+
+fold :: (Foldable t, Monoid m) => t m -> m
+fold xs =
+  foldr mappend mempty xs
+
+foldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m
+foldMap f xs =
+  foldr (\x acc -> mappend (f x) acc) mempty xs
+
+--------------------------------------------------------------------------------
+
+data List a = Nil | Cons a (List a) deriving (Eq, Show)
+
+instance Foldable List where
+  foldr f acc (Cons x rest) = foldr f (f x acc) rest
+  foldr f acc Nil = acc
+
+fromList :: [a] -> List a
+fromList [] = Nil
+fromList (x:rest) = Cons x (fromList rest)
+
+--------------------------------------------------------------------------------
+
+data Constant a b = Constant b deriving (Eq, Show)
+
+-- TODO: Is this correct?
+instance Foldable (Constant a) where
+  foldr f acc (Constant x) = f x acc
+
+--------------------------------------------------------------------------------
+
+data Two a b = Two a b deriving (Eq, Show)
+
+instance Foldable (Two a) where
+  foldr f acc (Two x y) = f y acc
+
+--------------------------------------------------------------------------------
+
+data Three a b c = Three a b c deriving (Eq, Show)
+
+instance Foldable (Three a b) where
+  foldr f acc (Three x y z) = f z acc
+
+--------------------------------------------------------------------------------
+
+data Three' a b = Three' a b b deriving (Eq, Show)
+
+instance Foldable (Three' a) where
+  foldr f acc (Three' x y z) = acc & f z & f y
+
+--------------------------------------------------------------------------------
+
+data Four' a b = Four' a b b b deriving (Eq, Show)
+
+instance Foldable (Four' a) where
+  foldr f acc (Four' w x y z) = acc & f z & f y & f x
+
+--------------------------------------------------------------------------------
+
+filterF :: (Applicative f, Foldable t, Monoid (f a)) => (a -> Bool) -> t a -> f a
+filterF pred xs =
+  foldr (\x acc -> if pred x then pure x `mappend` acc else acc) mempty xs